[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  <ebotcazou@adacore.com>

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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5e313305ed3c36798ae6abf830d53396519396e6..dc039a6d9197a9f59de142475b6f3bfd75d273ac 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,22 @@
+2019-08-13  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * 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  <miranda@adacore.com>
 
        * 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 9f1749482536957bab3a5c448689fdbb47fdc483..f98f2fa49a7801027453baf69b7d1d82684e2fa1 100644 (file)
--- 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 645a024b7e080dafafa6abd53363c6bc2fd000c8..ae8600c980333693281ebd354829148ced47d71a 100644 (file)
--- 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 e417a0719d1dac8a0f72cecbdc654d4051aa9f26..78740b956eeaddfbedfb288b29e939a02dce7050 100644 (file)
--- 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 887b0c3c3e73d30230e62995939cf618adbc5aeb..f3882db65fbc11e6eee6d5b41087a73f946629e2 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2019-08-13  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * gnat.dg/generic_inst10.adb, gnat.dg/generic_inst10_pkg.ads:
+       New testcase.
+
 2019-08-13  Javier Miranda  <miranda@adacore.com>
 
        * 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 (file)
index 0000000..75bb65a
--- /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 (file)
index 0000000..d9009ac
--- /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;