Ada: Fix assertion failure for unfrozen mutably tagged type as actual

...in instance.  An instantiation is a freezing point for the actuals,
so the mutably tagged type will be frozen by the instantiation, but this
happens too late in the current implementation of mutably tagged types,
because the declaration of their CW-equivalent type is not analyzed until
after the type is frozen.

gcc/ada/
	PR ada/123306
	* sem_ch12.adb (Analyze_One_Association): Immediately freeze the
	root type of mutably tagged types used as actual type parameters.

gcc/testsuite/
	* gnat.dg/specs/mutably_tagged1.ads: New test.

diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index d2478d24ec85f5b99e5f14238b0e9499ddc65598..729a6b145ac35e21ad26b57dc57a031d0815dd9f 100644 (file)
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -2657,9 +2657,20 @@ package body Sem_Ch12 is
                if Ekind (Etype (Match)) /= E_Void
                  and then Is_Mutably_Tagged_Type (Etype (Match))
                then
+                  --  The declaration of the CW-equivalent type of a mutably
+                  --  tagged type is analyzed when the tagged type is frozen.
+
+                  if Nkind (N) /= N_Formal_Package_Declaration
+                    and then Ekind (Defining_Identifier (Assoc.An_Formal)) /=
+                                                              E_Incomplete_Type
+                  then
+                     Freeze_Before (N, Root_Type (Etype (Match)));
+                  end if;
+
                   Rewrite (Match, New_Occurrence_Of
                     (Class_Wide_Equivalent_Type
                       (Etype (Match)), Sloc (Match)));
+
                   Analyze (Match);
                end if;
 

diff --git a/gcc/testsuite/gnat.dg/specs/mutably_tagged1.ads b/gcc/testsuite/gnat.dg/specs/mutably_tagged1.ads
new file mode 100644 (file)
index 0000000..4c03f0f
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/mutably_tagged1.ads
@@ -0,0 +1,15 @@
+-- { dg-do compile }
+-- { dg-options "-gnatX0" }
+
+package Mutably_Tagged1 is
+
+  generic
+    type T is private;
+  package G is
+  end G;
+
+  type Rec is tagged null record with Size'Class => 128;
+
+  package My_G is new G (Rec'Class);
+
+end Mutably_Tagged1;