[Ada] Fix assertion failure on double rederivation of private type

2020-06-05  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* sem_ch3.adb (Available_Full_View): New function returning
	either the full or the underlying full view.
	(Build_Full_Derivation): Add guard for the full view.
	(Copy_And_Build): Retrieve the underlying full view, if any,
	also if deriving a completion.
	(Build_Derived_Private_Type): Use Available_Full_View throughout
	to decide whether a full derivation must be done.

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 56e0aa26b53dace1d4c6486f78c17c5ccaf9add8..9523493b55be86251304ea3bd5e991b192fc5d7b 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -7612,6 +7612,10 @@ package body Sem_Ch3 is
       Full_Der  : Entity_Id           := New_Copy (Derived_Type);
       Full_P    : Entity_Id;
 
+      function Available_Full_View (Typ : Entity_Id) return Entity_Id;
+      --  Return the Full_View or Underlying_Full_View of Typ, whichever is
+      --  present (they cannot be both present for the same type), or Empty.
+
       procedure Build_Full_Derivation;
       --  Build full derivation, i.e. derive from the full view
 
@@ -7619,6 +7623,32 @@ package body Sem_Ch3 is
       --  Copy derived type declaration, replace parent with its full view,
       --  and build derivation
 
+      -------------------------
+      -- Available_Full_View --
+      -------------------------
+
+      function Available_Full_View (Typ : Entity_Id) return Entity_Id is
+      begin
+         if Present (Full_View (Typ)) then
+            return Full_View (Typ);
+
+         elsif Present (Underlying_Full_View (Typ)) then
+
+            --  We should be called on a type with an underlying full view
+            --  only by means of the recursive call made in Copy_And_Build
+            --  through the first call to Build_Derived_Type, or else if
+            --  the parent scope is being analyzed because we are deriving
+            --  a completion.
+
+            pragma Assert (Is_Completion or else In_Private_Part (Par_Scope));
+
+            return Underlying_Full_View (Typ);
+
+         else
+            return Empty;
+         end if;
+      end Available_Full_View;
+
       ---------------------------
       -- Build_Full_Derivation --
       ---------------------------
@@ -7638,7 +7668,9 @@ package body Sem_Ch3 is
          --  part of a child unit. In that case retrieve the full view of
          --  the parent momentarily.
 
-         elsif not In_Same_Source_Unit (N, Parent_Type) then
+         elsif not In_Same_Source_Unit (N, Parent_Type)
+           and then Present (Full_View (Parent_Type))
+         then
             Full_P := Full_View (Parent_Type);
             Exchange_Declarations (Parent_Type);
             Copy_And_Build;
@@ -7674,11 +7706,13 @@ package body Sem_Ch3 is
          --  completion, i.e. to build the underlying full view of the type,
          --  then use this underlying full view. We cannot do that if this
          --  is not a completion, i.e. to build the full view of the type,
-         --  because this would break the privacy status of the parent.
+         --  because this would break the privacy of the parent type, except
+         --  if the parent scope is being analyzed because we are deriving a
+         --  completion.
 
          if Is_Private_Type (Full_Parent)
            and then Present (Underlying_Full_View (Full_Parent))
-           and then Is_Completion
+           and then (Is_Completion or else In_Private_Part (Par_Scope))
          then
             Full_Parent := Underlying_Full_View (Full_Parent);
          end if;
@@ -7929,9 +7963,7 @@ package body Sem_Ch3 is
          --  case (see point 5. of its head comment) since we build it for the
          --  derived subtype.
 
-         if (Present (Full_View (Parent_Type))
-             or else (Present (Underlying_Full_View (Parent_Type))
-                       and then Is_Completion))
+         if Present (Available_Full_View (Parent_Type))
            and then not Is_Itype (Derived_Type)
          then
             declare
@@ -7983,14 +8015,8 @@ package body Sem_Ch3 is
             end;
          end if;
 
-      elsif (Present (Full_View (Parent_Type))
-              and then
-             Has_Discriminants (Full_View (Parent_Type)))
-        or else (Present (Underlying_Full_View (Parent_Type))
-                  and then
-                 Has_Discriminants (Underlying_Full_View (Parent_Type))
-                  and then
-                 Is_Completion)
+      elsif Present (Available_Full_View (Parent_Type))
+        and then Has_Discriminants (Available_Full_View (Parent_Type))
       then
          if Has_Unknown_Discriminants (Parent_Type)
            and then Nkind (Subtype_Indication (Type_Definition (N))) =
@@ -8027,7 +8053,7 @@ package body Sem_Ch3 is
 
          Set_Stored_Constraint (Derived_Type, No_Elist);
          Set_Is_Constrained
-           (Derived_Type, Is_Constrained (Full_View (Parent_Type)));
+           (Derived_Type, Is_Constrained (Available_Full_View (Parent_Type)));
 
       else
          --  Untagged type, No discriminants on either view
@@ -8040,8 +8066,8 @@ package body Sem_Ch3 is
          end if;
 
          if Present (Discriminant_Specifications (N))
-           and then Present (Full_View (Parent_Type))
-           and then not Is_Tagged_Type (Full_View (Parent_Type))
+           and then Present (Available_Full_View (Parent_Type))
+           and then not Is_Tagged_Type (Available_Full_View (Parent_Type))
          then
             Error_Msg_N ("cannot add discriminants to untagged type", N);
          end if;
@@ -8074,8 +8100,8 @@ package body Sem_Ch3 is
          --  tagged, this mechanism will not work because we cannot derive from
          --  the tagged full view unless we have an extension.
 
-         if Present (Full_View (Parent_Type))
-           and then not Is_Tagged_Type (Full_View (Parent_Type))
+         if Present (Available_Full_View (Parent_Type))
+           and then not Is_Tagged_Type (Available_Full_View (Parent_Type))
            and then not Error_Posted (N)
          then
             Build_Full_Derivation;