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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2019-07-01 Hristian Kirtchev <kirtc...@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.--- gcc/ada/freeze.adb
+++ 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
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/freezing1.adb
@@ -0,0 +1,5 @@
+-- { dg-do compile }
+
+package body Freezing1 is
+ procedure Foo is null;
+end Freezing1;
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
