[Ada] Crash due to missing freeze nodes in transient scope

The following patch updates the freezing of expressions to insert the
generated freeze nodes prior to the expression that produced them when
the context is a transient scope within a type initialization procedure.
This ensures that the nodes are properly interleaved with respect to the
constructs that generated them.

2019-07-01  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* freeze.adb (Freeze_Expression): Remove the horrible useless
	name hiding of N. Insert the freeze nodes generated by the
	expression prior to the expression when the nearest enclosing
	scope is transient.

gcc/testsuite/

	* gnat.dg/freezing1.adb, gnat.dg/freezing1.ads,
	gnat.dg/freezing1_pack.adb, gnat.dg/freezing1_pack.ads: New
	testcase.

From-SVN: r272854

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 368e120ce2dc8b757eda37712832e7aff77ef3e2..5d58a2cfab0b98cf8ea51a7a92ac29ca5462d99b 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2019-07-01  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * freeze.adb (Freeze_Expression): Remove the horrible useless
+       name hiding of N. Insert the freeze nodes generated by the
+       expression prior to the expression when the nearest enclosing
+       scope is transient.
+
 2019-07-01  Pierre-Marie de Rodat  <derodat@adacore.com>
 
        * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Fix

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 8e55fb8ab362d81620a214b9c85ea8875c478a9c..f7e74afab64d2913dfbb4b403d2d8deadaa1f343 100644 (file)
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -7665,9 +7665,8 @@ package body Freeze is
         or else Ekind (Current_Scope) = E_Void
       then
          declare
-            N            : constant Node_Id := Current_Scope;
-            Freeze_Nodes : List_Id          := No_List;
-            Pos          : Int              := Scope_Stack.Last;
+            Freeze_Nodes : List_Id := No_List;
+            Pos          : Int     := Scope_Stack.Last;
 
          begin
             if Present (Desig_Typ) then
@@ -7700,7 +7699,19 @@ package body Freeze is
             end if;
 
             if Is_Non_Empty_List (Freeze_Nodes) then
-               if No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then
+
+               --  When the current scope is transient, insert the freeze nodes
+               --  prior to the expression that produced them. Transient scopes
+               --  may create additional declarations when finalizing objects
+               --  or managing the secondary stack. Inserting the freeze nodes
+               --  of those constructs prior to the scope would result in a
+               --  freeze-before-declaration, therefore the freeze node must
+               --  remain interleaved with their constructs.
+
+               if Scope_Is_Transient then
+                  Insert_Actions (N, Freeze_Nodes);
+
+               elsif No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then
                   Scope_Stack.Table (Pos).Pending_Freeze_Actions :=
                     Freeze_Nodes;
                else

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e5206340021c10443136260df715798f79a16b8e..a64cb528b277fd425e69c215268ab3c627298bf9 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2019-07-01  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * gnat.dg/freezing1.adb, gnat.dg/freezing1.ads,
+       gnat.dg/freezing1_pack.adb, gnat.dg/freezing1_pack.ads: New
+       testcase.
+
 2019-07-01  Jan Hubicka  <hubicka@ucw.cz>
 
        PR lto/91028

diff --git a/gcc/testsuite/gnat.dg/freezing1.adb b/gcc/testsuite/gnat.dg/freezing1.adb
new file mode 100644 (file)
index 0000000..87d8246
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/freezing1.adb
@@ -0,0 +1,5 @@
+--  { dg-do compile }
+
+package body Freezing1 is
+   procedure Foo is null;
+end Freezing1;

diff --git a/gcc/testsuite/gnat.dg/freezing1.ads b/gcc/testsuite/gnat.dg/freezing1.ads
new file mode 100644 (file)
index 0000000..f81bc78
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/freezing1.ads
@@ -0,0 +1,10 @@
+with Freezing1_Pack; use Freezing1_Pack;
+
+package Freezing1 is
+   type T is abstract tagged record
+      Collection : access I_Interface_Collection'Class :=
+        new I_Interface_Collection'Class'(Factory.Create_Collection);
+   end record;
+
+   procedure Foo;
+end Freezing1;

diff --git a/gcc/testsuite/gnat.dg/freezing1_pack.adb b/gcc/testsuite/gnat.dg/freezing1_pack.adb
new file mode 100644 (file)
index 0000000..11172af
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/freezing1_pack.adb
@@ -0,0 +1,8 @@
+package body Freezing1_Pack is
+   function Create_Collection
+     (Factory : in T_Factory) return I_Interface_Collection'Class
+   is
+   begin
+      return Implem'(null record);
+   end Create_Collection;
+end Freezing1_Pack;

diff --git a/gcc/testsuite/gnat.dg/freezing1_pack.ads b/gcc/testsuite/gnat.dg/freezing1_pack.ads
new file mode 100644 (file)
index 0000000..74d88b8
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/freezing1_pack.ads
@@ -0,0 +1,16 @@
+package Freezing1_Pack is
+   type T_Factory is abstract tagged private;
+   type I_Interface_Collection is interface;
+
+   Factory : constant T_Factory;
+
+   function Create_Collection
+     (Factory : in T_Factory) return I_Interface_Collection'Class;
+
+   type Implem is new I_Interface_Collection with null record;
+
+private
+   type T_Factory is tagged null record;
+
+   Factory : constant T_Factory := T_Factory'(null record);
+end Freezing1_Pack;