[Ada] Fix internal error on package instantiation on private type

This fixes an assertion failure in gigi triggered by the instantiation
of a generic package, in a visible part of another package, done on a
private type whose full view is a type derived from a scalar or an
access type.

The problem is that the front-end creates and inserts two different
freeze nodes in the expanded tree for the partial and the full views of
the private subtype created by the instantiation, which is not correct:
partial and full views of a given (sub)type must point to the same
freeze node, if any.

The patch also adds an assertion checking this property in the front-end
so as to catch the inconsistency higher in the chain.

2018-12-03  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* freeze.adb (Freeze_Entity): Do not freeze the partial view of
	a private subtype if its base type is also private with delayed
	freeze before the full type declaration of the base type has
	been seen.
	* sem_ch7.adb (Preserve_Full_Attributes): Add assertion on
	freeze node.

gcc/testsuite/

	* gnat.dg/generic_inst2.adb, gnat.dg/generic_inst2.ads,
	gnat.dg/generic_inst2_c.ads: New testcase.

From-SVN: r266754

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 481f9da53e6b09d8b0ede2f42e67b2f9a783fd5c..2a3ff0ff548d239886b64b582bae1d38c0aae1c4 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2018-12-03  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * freeze.adb (Freeze_Entity): Do not freeze the partial view of
+       a private subtype if its base type is also private with delayed
+       freeze before the full type declaration of the base type has
+       been seen.
+       * sem_ch7.adb (Preserve_Full_Attributes): Add assertion on
+       freeze node.
+
 2018-12-03  Eric Botcazou  <ebotcazou@adacore.com>
 
        * exp_ch3.adb (Build_Record_Init_Proc): Inherit an

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index afb347969ca072fac6cd885501cb02181408ebeb..412789f56b29bcc4627c0fef12564ee4c32cf295 100644 (file)
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -6239,13 +6239,34 @@ package body Freeze is
 
                goto Leave;
 
-            --  Case of no full view present. If entity is derived or subtype,
+            --  Case of no full view present. If entity is subtype or derived,
             --  it is safe to freeze, correctness depends on the frozen status
             --  of parent. Otherwise it is either premature usage, or a Taft
             --  amendment type, so diagnosis is at the point of use and the
             --  type might be frozen later.
 
-            elsif E /= Base_Type (E) or else Is_Derived_Type (E) then
+            elsif E /= Base_Type (E) then
+               declare
+                  Btyp : constant Entity_Id := Base_Type (E);
+
+               begin
+                  --  However, if the base type is itself private and has no
+                  --  (underlying) full view either, wait until the full type
+                  --  declaration is seen and all the full views are created.
+
+                  if Is_Private_Type (Btyp)
+                    and then No (Full_View (Btyp))
+                    and then No (Underlying_Full_View (Btyp))
+                    and then Has_Delayed_Freeze (Btyp)
+                    and then No (Freeze_Node (Btyp))
+                  then
+                     Set_Is_Frozen (E, False);
+                     Result := No_List;
+                     goto Leave;
+                  end if;
+               end;
+
+            elsif Is_Derived_Type (E) then
                null;
 
             else

diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 28119dfd121f2f74dc547ebb2ed8b98ee9acdcb2..d85f847ed49f9aedce9341de8014189f17482c29 100644 (file)
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -2733,6 +2733,15 @@ package body Sem_Ch7 is
             Propagate_Concurrent_Flags (Priv, Base_Type (Full));
          end if;
 
+         --  As explained in Freeze_Entity, private types are required to point
+         --  to the same freeze node as their corresponding full view, if any.
+         --  But we ought not to overwrite a node already inserted in the tree.
+
+         pragma Assert (Serious_Errors_Detected /= 0
+           or else No (Freeze_Node (Priv))
+           or else No (Parent (Freeze_Node (Priv)))
+           or else Freeze_Node (Priv) = Freeze_Node (Full));
+
          Set_Freeze_Node (Priv, Freeze_Node (Full));
 
          --  Propagate Default_Initial_Condition-related attributes from the

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b69ad66131680fe2239491846f16d58f13e40f8f..2e63d0ad405412d2a76109d2765b233b0c084634 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-12-03  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * gnat.dg/generic_inst2.adb, gnat.dg/generic_inst2.ads,
+       gnat.dg/generic_inst2_c.ads: New testcase.
+
 2018-12-03  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gnat.dg/overload2.adb, gnat.dg/overload2_p.adb,

diff --git a/gcc/testsuite/gnat.dg/generic_inst2.adb b/gcc/testsuite/gnat.dg/generic_inst2.adb
new file mode 100644 (file)
index 0000000..2ccebb0
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/generic_inst2.adb
@@ -0,0 +1,5 @@
+--  { dg-do compile }
+
+package body Generic_Inst2 is
+   procedure Foo (X : not null access T) is null;
+end;

diff --git a/gcc/testsuite/gnat.dg/generic_inst2.ads b/gcc/testsuite/gnat.dg/generic_inst2.ads
new file mode 100644 (file)
index 0000000..3124a1d
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/generic_inst2.ads
@@ -0,0 +1,10 @@
+with Generic_Inst2_C;
+
+package Generic_Inst2 is
+   type T is private;
+   procedure Foo (X : not null access T);
+   package CI is new Generic_Inst2_C (T, Foo => Foo);
+private
+   type S is access Integer;
+   type T is new S;
+end;

diff --git a/gcc/testsuite/gnat.dg/generic_inst2_c.ads b/gcc/testsuite/gnat.dg/generic_inst2_c.ads
new file mode 100644 (file)
index 0000000..df1000b
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/generic_inst2_c.ads
@@ -0,0 +1,5 @@
+generic
+   type T;
+   with procedure Foo (X : not null access T) is null;
+   with procedure Bar (X : not null access T) is null;
+package Generic_Inst2_C is end;