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 --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index aa15166fa8601c3263b4507550116ed05e2f8eed..79986bb48c5ccb5715abf02f0e2fb817b5d1affe 100644 (file)
--- 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 (file)
index 0000000..d1c85e1
--- /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 (file)
index 0000000..681efbc
--- /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 (file)
index 0000000..1570405
--- /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 (file)
index 0000000..5dfe119
--- /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 (file)
index 0000000..d769b4d
--- /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;