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)
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch7.adb | 65 ++++++++++++++++++++++++++++++--------------
gcc/ada/exp_unst.adb | 2 ++
2 files changed, 47 insertions(+), 20 deletions(-)
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index d60c6edecdf..600d333952c 100644
--- 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);
+ pragma
+ Assert
+ (Nkind (N)
+ in N_Loop_Statement | N_Block_Statement | N_Freeze_Entity);
- 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));
+ 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 58f668944a0..9a1ed7067a6 100644
--- 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;
--
2.51.0
