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.
Tested on x86-64/Linux, applied on the mainline.
2025-11-02 Eric Botcazou <[email protected]>
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.
2025-11-02 Eric Botcazou <[email protected]>
* 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.
--
Eric Botcazou-- { 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;
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;
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;
with Unknown_Discr1_Pkg.G;
package Unknown_Discr1_Pkg.Inst is new Unknown_Discr1_Pkg.G (Tagged_Type);
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;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index aa15166fa86..79986bb48c5 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)))
