https://gcc.gnu.org/g:12f3c63de3b4e53b63347c4bee6a82ce66d0078a
commit r16-4934-g12f3c63de3b4e53b63347c4bee6a82ce66d0078a Author: Eric Botcazou <[email protected]> Date: Sun Nov 2 19:36:16 2025 +0100 Ada: Fix crash on tagged private type with unknown discriminants This is an old issue with the extension of a tagged private type declared with unknown discriminants in the public part of a generic child unit, although the generic context is not a key factor (i.e. this also happens for a nongeneric child unit). The public part of a child unit does not have visibility on the private part of its parent, so the extension also has unknown discriminants. gcc/ada/ PR ada/58881 * sem_ch3.adb (Build_Derived_Private_Type): Build the underlying full view when the derivation occurs in the public part of the scope of the parent. (Build_Derived_Record_Type): Propagate Has_Unknown_Discriminants in the same circumstances. (Constrain_Discriminated_Type): Give a specific error message for any type with the Has_Unknown_Discriminants flag. gcc/testsuite/ * gnat.dg/specs/unknown_discr1.ads: New test. * gnat.dg/specs/unknown_discr1_pkg.ads: New helper. * gnat.dg/specs/unknown_discr1_pkg-child.ads: Likewise. * gnat.dg/specs/unknown_discr1_pkg-g.ads: Likewise. * gnat.dg/specs/unknown_discr1_pkg-inst.ads: Likewise. Diff: --- gcc/ada/sem_ch3.adb | 64 +++++++++++++++------- gcc/testsuite/gnat.dg/specs/unknown_discr1.ads | 23 ++++++++ .../gnat.dg/specs/unknown_discr1_pkg-child.ads | 17 ++++++ .../gnat.dg/specs/unknown_discr1_pkg-g.ads | 21 +++++++ .../gnat.dg/specs/unknown_discr1_pkg-inst.ads | 3 + gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg.ads | 9 +++ 6 files changed, 116 insertions(+), 21 deletions(-) diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index aa15166fa860..79986bb48c5c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8500,26 +8500,28 @@ package body Sem_Ch3 is Full_P := Full_View (Parent_Type); -- A type extension of a type with unknown discriminants is an - -- indefinite type that the back-end cannot handle directly. + -- indefinite type that the back end cannot handle directly. -- We treat it as a private type, and build a completion that is -- derived from the full view of the parent, and hopefully has - -- known discriminants. + -- known discriminants. Note that the type will nevertheless be + -- turned into a public type in Build_Derived_Record_Type as for + -- any other extension; the only difference is the completion. -- If the full view of the parent type has an underlying record view, - -- use it to generate the underlying record view of this derived type + -- use it to generate the underlying record view of the derived type -- (required for chains of derivations with unknown discriminants). - -- Minor optimization: we avoid the generation of useless underlying - -- record view entities if the private type declaration has unknown - -- discriminants but its corresponding full view has no - -- discriminants. + -- Minor optimization: we avoid creating useless underlying record + -- view entities when the private type has unknown discriminants but + -- its corresponding full view has no discriminants. if Has_Unknown_Discriminants (Parent_Type) and then Present (Full_P) and then (Has_Discriminants (Full_P) or else Present (Underlying_Record_View (Full_P))) - and then not In_Open_Scopes (Par_Scope) - and then Expander_Active + and then (not In_Open_Scopes (Par_Scope) + or else not (In_Package_Body (Par_Scope) + or else In_Private_Part (Par_Scope))) then declare Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T'); @@ -8534,7 +8536,7 @@ package body Sem_Ch3 is -- Build anonymous completion, as a derivation from the full -- view of the parent. This is not a completion in the usual - -- sense, because the current type is not private. + -- sense, because the derived type is no longer private. Decl := Make_Full_Type_Declaration (Loc, @@ -8557,8 +8559,18 @@ package body Sem_Ch3 is Underlying_Record_View (Full_P)); end if; + -- If the extension is done in the public part of the scope of + -- the parent, its visible declarations have been installed, so + -- we first need to uninstall them before reinstalling both the + -- private and the visible declarations in this order. + + if In_Open_Scopes (Par_Scope) then + Uninstall_Declarations (Par_Scope); + end if; + Install_Private_Declarations (Par_Scope); Install_Visible_Declarations (Par_Scope); + Insert_Before (N, Decl); -- Mark entity as an underlying record view before analysis, @@ -8582,6 +8594,13 @@ package body Sem_Ch3 is Uninstall_Declarations (Par_Scope); + -- If the extension is done in the public part of the scope of + -- the parent, reinstall the visible declarations only. + + if In_Open_Scopes (Par_Scope) then + Install_Visible_Declarations (Par_Scope); + end if; + if Etype (Full_Der) = Any_Type then pragma Assert (Serious_Errors_Detected > 0); return; @@ -10007,13 +10026,15 @@ package body Sem_Ch3 is or else Unknown_Discriminants_Present (N)); -- The partial view of the parent may have unknown discriminants, - -- but if the full view has discriminants and the parent type is - -- in scope they must be inherited. + -- but when its full view has discriminants and is visible, then + -- these discriminants must be inherited. elsif Has_Unknown_Discriminants (Parent_Type) and then (not Has_Discriminants (Parent_Type) - or else not In_Open_Scopes (Scope (Parent_Base))) + or else not In_Open_Scopes (Scope (Parent_Base)) + or else not (In_Package_Body (Scope (Parent_Base)) + or else In_Private_Part (Scope (Parent_Base)))) then Set_Has_Unknown_Discriminants (Derived_Type); end if; @@ -15144,19 +15165,20 @@ package body Sem_Ch3 is Fixup_Bad_Constraint; return; - -- Check that the type has visible discriminants. The type may be - -- a private type with unknown discriminants whose full view has - -- discriminants which are invisible. + -- Check that the type has known discriminants - elsif not Has_Discriminants (T) - or else - (Has_Unknown_Discriminants (T) - and then Is_Private_Type (T)) - then + elsif Has_Unknown_Discriminants (T) then + Error_Msg_N ("invalid constraint: type has unknown discriminants", C); + Fixup_Bad_Constraint; + return; + + elsif not Has_Discriminants (T) then Error_Msg_N ("invalid constraint: type has no discriminant", C); Fixup_Bad_Constraint; return; + -- And is not already constrained + elsif Is_Constrained (E) or else (Ekind (E) = E_Class_Wide_Subtype and then Present (Discriminant_Constraint (E))) diff --git a/gcc/testsuite/gnat.dg/specs/unknown_discr1.ads b/gcc/testsuite/gnat.dg/specs/unknown_discr1.ads new file mode 100644 index 000000000000..d1c85e1a2c77 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/unknown_discr1.ads @@ -0,0 +1,23 @@ +-- { dg-do compile } + +with Unknown_Discr1_Pkg; use Unknown_Discr1_Pkg; +with Unknown_Discr1_Pkg.Child; +with Unknown_Discr1_Pkg.Inst; + +package Unknown_Discr1 is + + A : Tagged_Type (0); -- { dg-error "type has unknown discriminants" } + + B : Child.Derived_1 (1); -- { dg-error "type has unknown discriminants" } + + C : Child.Derived_2 (2); -- { dg-error "type has unknown discriminants" } + + D : Child.Nested.Derived_3 (3); -- { dg-error "type has unknown discriminants" } + + E : Inst.Derived_1 (1); -- { dg-error "type has unknown discriminants" } + + F : Inst.Derived_2 (2); -- { dg-error "type has unknown discriminants" } + + G : Inst.Nested.Derived_3 (3); -- { dg-error "type has unknown discriminants" } + +end Unknown_Discr1; diff --git a/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg-child.ads b/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg-child.ads new file mode 100644 index 000000000000..681efbc70c31 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg-child.ads @@ -0,0 +1,17 @@ +package Unknown_Discr1_Pkg.Child is + + type Derived_1 is new Tagged_Type with null record; + + type Derived_2 is new Derived_1 with null record; + + package Nested is + + type Derived_3 is new Tagged_Type with private; + + private + + type Derived_3 is new Tagged_Type with null record; + + end Nested; + +end Unknown_Discr1_Pkg.Child; diff --git a/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg-g.ads b/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg-g.ads new file mode 100644 index 000000000000..15704057ff7b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg-g.ads @@ -0,0 +1,21 @@ +generic + + type Base (<>) is new Tagged_Type with private; + +package Unknown_Discr1_Pkg.G is + + type Derived_1 is new Base with null record; + + type Derived_2 is new Derived_1 with null record; + + package Nested is + + type Derived_3 is new Tagged_Type with private; + + private + + type Derived_3 is new Tagged_Type with null record; + + end Nested; + +end Unknown_Discr1_Pkg.G; diff --git a/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg-inst.ads b/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg-inst.ads new file mode 100644 index 000000000000..5dfe1199e80c --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg-inst.ads @@ -0,0 +1,3 @@ +with Unknown_Discr1_Pkg.G; + +package Unknown_Discr1_Pkg.Inst is new Unknown_Discr1_Pkg.G (Tagged_Type); diff --git a/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg.ads b/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg.ads new file mode 100644 index 000000000000..d769b4d13602 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/unknown_discr1_pkg.ads @@ -0,0 +1,9 @@ +package Unknown_Discr1_Pkg is + + type Tagged_Type (<>) is tagged limited private; + +private + + type Tagged_Type (Kind : Integer) is tagged limited null record; + +end Unknown_Discr1_Pkg;
