ada: Fix another incorrectly nested procedure

When unnesting a loop, its body is moved inside a procedure, and inner
entities have their scope adjusted. The current GNAT Tree at this stage
is incoherent wrt scope information, and some nested entities are
incorrectly scoped, possibly leading to a crash of the unnester.

The existing Fixup_Inner_Scopes procedure has been added to adjust the
incoherences after the fact because fixing them earlier has proven to be
more complex than expected. This change adds one more adjustment by this
procedure for TSS (Type Support Subprogram) that may be embedded within
N_Freeze_Entity nodes.

gcc/ada/ChangeLog:

	* exp_ch7.adb (Fixup_Inner_Scopes): Adjust to handle N_Freeze_Entity nodes.
	* exp_unst.adb (Get_Level): Assert when the function didn't find the
	nested level (indicates that inner sub has scope pointing higher in
	the stack)

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index d60c6edecdfff81a4b02683da900cacc011ea5f5..600d333952c499db508fd4ede74efa1ff95228ce 100644 (file)
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -9244,7 +9244,7 @@ package body Exp_Ch7 is
 
    procedure Unnest_Loop (Loop_Stmt : Node_Id) is
 
-      procedure Fixup_Inner_Scopes (Loop_Or_Block : Node_Id);
+      procedure Fixup_Inner_Scopes (N : Node_Id);
       --  This procedure fixes the scope for 2 identified cases of incorrect
       --  scope information.
       --
@@ -9271,6 +9271,9 @@ package body Exp_Ch7 is
       --  leaves the Tree in an incoherent state (i.e. the inner procedure must
       --  have its enclosing procedure in its scope ancestries).
 
+      --  The same issue exists for freeze nodes with associated TSS: the node
+      --  is moved but the TSS procedures are not correctly nested.
+
       --  2) The second case happens when an object declaration is created
       --  within a loop used to initialize the 'others' components of an
       --  aggregate that is nested within a transient scope. When the transient
@@ -9298,40 +9301,62 @@ package body Exp_Ch7 is
       --  an actual entity set). But unfortunately this proved harder to
       --  implement ???
 
-      procedure Fixup_Inner_Scopes (Loop_Or_Block : Node_Id) is
-         Stmt              : Node_Id;
-         Loop_Or_Block_Ent : Entity_Id;
-         Ent_To_Fix        : Entity_Id;
-         Decl              : Node_Id := Empty;
+      procedure Fixup_Inner_Scopes (N : Node_Id) is
+         Stmt       : Node_Id := Empty;
+         Ent        : Entity_Id;
+         Ent_To_Fix : Entity_Id;
+         Decl       : Node_Id := Empty;
+         Elmt       : Elmt_Id := No_Elmt;
       begin
-         pragma Assert (Nkind (Loop_Or_Block) in
-           N_Loop_Statement | N_Block_Statement);
-
-         Loop_Or_Block_Ent := Entity (Identifier (Loop_Or_Block));
-         if Nkind (Loop_Or_Block) = N_Loop_Statement then
-            Stmt := First (Statements (Loop_Or_Block));
-         else -- N_Block_Statement
-            Stmt := First
-              (Statements (Handled_Statement_Sequence (Loop_Or_Block)));
-            Decl := First (Declarations (Loop_Or_Block));
+         pragma
+           Assert
+             (Nkind (N)
+              in N_Loop_Statement | N_Block_Statement | N_Freeze_Entity);
+
+         if Nkind (N) = N_Freeze_Entity then
+            Ent := Scope (Entity (N));
+         else
+            Ent := Entity (Identifier (N));
          end if;
 
+         case Nkind (N) is
+            when N_Loop_Statement =>
+               Stmt := First (Statements (N));
+
+            when N_Block_Statement =>
+               Stmt := First (Statements (Handled_Statement_Sequence (N)));
+               Decl := First (Declarations (N));
+
+            when N_Freeze_Entity =>
+               if Present (TSS_Elist (N)) then
+                  Elmt := First_Elmt (TSS_Elist (N));
+                  while Present (Elmt) loop
+                     Ent_To_Fix := Node (Elmt);
+                     Set_Scope (Ent_To_Fix, Ent);
+                     Next_Elmt (Elmt);
+                  end loop;
+               end if;
+
+            when others =>
+               pragma Assert (False);
+         end case;
+
          --  Fix scopes for any object declaration found in the block
          while Present (Decl) loop
             if Nkind (Decl) = N_Object_Declaration then
                Ent_To_Fix := Defining_Identifier (Decl);
-               Set_Scope (Ent_To_Fix, Loop_Or_Block_Ent);
+               Set_Scope (Ent_To_Fix, Ent);
             end if;
             Next (Decl);
          end loop;
 
          while Present (Stmt) loop
-            if Nkind (Stmt) = N_Block_Statement
-              and then Is_Abort_Block (Stmt)
+            if Nkind (Stmt) = N_Block_Statement and then Is_Abort_Block (Stmt)
             then
                Ent_To_Fix := Entity (Identifier (Stmt));
-               Set_Scope (Ent_To_Fix, Loop_Or_Block_Ent);
-            elsif Nkind (Stmt) in N_Block_Statement | N_Loop_Statement
+               Set_Scope (Ent_To_Fix, Ent);
+            elsif Nkind (Stmt)
+                  in N_Block_Statement | N_Loop_Statement | N_Freeze_Entity
             then
                Fixup_Inner_Scopes (Stmt);
             end if;

diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index 58f668944a0ad878624f0d17f4c872b2a66cdd63..9a1ed7067a69a18c7e9cd839a00558d83b2c0afd 100644 (file)
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -220,6 +220,8 @@ package body Exp_Unst is
          else
             Lev := Lev + 1;
             S   := Enclosing_Subprogram (S);
+
+            pragma Assert (Present (S));
          end if;
       end loop;
    end Get_Level;