[COMMITTED] ada: Crash on loop in dispatching conditional entry call
Commit Message
From: Javier Miranda <miranda@adacore.com>
gcc/ada/
* exp_ch9.adb
(Expand_N_Conditional_Entry_Call): Factorize code to avoid
duplicating subtrees; required to avoid problems when the copied
code has implicit labels.
* sem_util.ads (New_Copy_Separate_List): Removed.
(New_Copy_Separate_Tree): Removed.
* sem_util.adb (New_Copy_Separate_List): Removed.
(New_Copy_Separate_Tree): Removed.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch9.adb | 38 +++++++++++----
gcc/ada/sem_util.adb | 107 -------------------------------------------
gcc/ada/sem_util.ads | 10 ----
3 files changed, 30 insertions(+), 125 deletions(-)
@@ -7712,7 +7712,7 @@ package body Exp_Ch9 is
-- or else K = Ada.Tags.TK_Tagged
-- then
-- <dispatching-call>;
- -- <triggering-statements>
+ -- -- <triggering-statements> (code factorized after if-stmt)
-- else
-- S :=
@@ -7737,11 +7737,14 @@ package body Exp_Ch9 is
-- <dispatching-call>;
-- end if;
- -- <triggering-statements>
+ -- -- <triggering-statements> (code factorized after if-stmt)
-- else
-- <else-statements>
+ -- goto L0; -- skip triggering statements
-- end if;
-- end if;
+ -- <triggering-statements>
+ -- L0:
-- end;
procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
@@ -7757,6 +7760,8 @@ package body Exp_Ch9 is
Decl : Node_Id;
Decls : List_Id;
Formals : List_Id;
+ Label : Node_Id;
+ Label_Id : Entity_Id := Empty;
Lim_Typ_Stmts : List_Id;
N_Stats : List_Id;
Obj : Entity_Id;
@@ -7883,12 +7888,13 @@ package body Exp_Ch9 is
-- then
-- <dispatching-call>
-- end if;
- -- <normal-statements>
+ -- -- <triggering-stataments> (code factorized after if-stmt)
-- else
-- <else-statements>
+ -- goto L0; -- skip triggering statements
-- end if;
- N_Stats := New_Copy_Separate_List (Statements (Alt));
+ N_Stats := New_List;
Prepend_To (N_Stats,
Make_Implicit_If_Statement (N,
@@ -7922,6 +7928,14 @@ package body Exp_Ch9 is
Then_Statements =>
New_List (Blk)));
+ Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
+ Set_Entity (Label_Id,
+ Make_Defining_Identifier (Loc, Chars (Label_Id)));
+
+ Append_To (Else_Statements (N),
+ Make_Goto_Statement (Loc,
+ Name => New_Occurrence_Of (Entity (Label_Id), Loc)));
+
Append_To (Conc_Typ_Stmts,
Make_Implicit_If_Statement (N,
Condition => New_Occurrence_Of (B, Loc),
@@ -7930,15 +7944,14 @@ package body Exp_Ch9 is
-- Generate:
-- <dispatching-call>;
- -- <triggering-statements>
+ -- -- <triggering-statements> (code factorized after if-stmt)
- Lim_Typ_Stmts := New_Copy_Separate_List (Statements (Alt));
- Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
+ Lim_Typ_Stmts := New_List (New_Copy_Tree (Blk));
-- Generate:
-- if K = Ada.Tags.TK_Limited_Tagged
-- or else K = Ada.Tags.TK_Tagged
- -- then
+ -- then
-- Lim_Typ_Stmts
-- else
-- Conc_Typ_Stmts
@@ -7950,6 +7963,15 @@ package body Exp_Ch9 is
Then_Statements => Lim_Typ_Stmts,
Else_Statements => Conc_Typ_Stmts));
+ Label := Make_Label (Loc, Label_Id);
+ Append_To (Decls,
+ Make_Implicit_Label_Declaration (Loc,
+ Defining_Identifier => Entity (Label_Id),
+ Label_Construct => Label));
+
+ Append_List_To (Stmts, Statements (Alt)); -- triggering-statements
+ Append_To (Stmts, Label);
+
Rewrite (N,
Make_Block_Statement (Loc,
Declarations =>
@@ -22886,113 +22886,6 @@ package body Sem_Util is
end if;
end New_Copy_List_Tree;
- ----------------------------
- -- New_Copy_Separate_List --
- ----------------------------
-
- function New_Copy_Separate_List (List : List_Id) return List_Id is
- begin
- if List = No_List then
- return No_List;
-
- else
- declare
- List_Copy : constant List_Id := New_List;
- N : Node_Id := First (List);
-
- begin
- while Present (N) loop
- Append (New_Copy_Separate_Tree (N), List_Copy);
- Next (N);
- end loop;
-
- return List_Copy;
- end;
- end if;
- end New_Copy_Separate_List;
-
- ----------------------------
- -- New_Copy_Separate_Tree --
- ----------------------------
-
- function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id is
- function Search_Decl (N : Node_Id) return Traverse_Result;
- -- Subtree visitor which collects declarations
-
- procedure Search_Declarations is new Traverse_Proc (Search_Decl);
- -- Subtree visitor instantiation
-
- -----------------
- -- Search_Decl --
- -----------------
-
- Decls : Elist_Id;
-
- function Search_Decl (N : Node_Id) return Traverse_Result is
- begin
- if Nkind (N) in N_Declaration then
- Append_New_Elmt (N, Decls);
- end if;
-
- return OK;
- end Search_Decl;
-
- -- Local variables
-
- Source_Copy : constant Node_Id := New_Copy_Tree (Source);
-
- -- Start of processing for New_Copy_Separate_Tree
-
- begin
- Decls := No_Elist;
- Search_Declarations (Source_Copy);
-
- -- Associate a new Entity with all the subtree declarations (keeping
- -- their original name).
-
- if Present (Decls) then
- declare
- Elmt : Elmt_Id;
- Decl : Node_Id;
- New_E : Entity_Id;
-
- begin
- Elmt := First_Elmt (Decls);
- while Present (Elmt) loop
- Decl := Node (Elmt);
- New_E := Make_Temporary (Sloc (Decl), 'P');
-
- if Nkind (Decl) = N_Expression_Function then
- Decl := Specification (Decl);
- end if;
-
- if Nkind (Decl) in N_Function_Instantiation
- | N_Function_Specification
- | N_Generic_Function_Renaming_Declaration
- | N_Generic_Package_Renaming_Declaration
- | N_Generic_Procedure_Renaming_Declaration
- | N_Package_Body
- | N_Package_Instantiation
- | N_Package_Renaming_Declaration
- | N_Package_Specification
- | N_Procedure_Instantiation
- | N_Procedure_Specification
- then
- Set_Chars (New_E, Chars (Defining_Unit_Name (Decl)));
- Set_Defining_Unit_Name (Decl, New_E);
- else
- Set_Chars (New_E, Chars (Defining_Identifier (Decl)));
- Set_Defining_Identifier (Decl, New_E);
- end if;
-
- Next_Elmt (Elmt);
- end loop;
- end;
- end if;
-
- return Source_Copy;
- end New_Copy_Separate_Tree;
-
-------------------
-- New_Copy_Tree --
-------------------
@@ -2623,16 +2623,6 @@ package Sem_Util is
-- below. As for New_Copy_Tree, it is illegal to attempt to copy extended
-- nodes (entities) either directly or indirectly using this function.
- function New_Copy_Separate_List (List : List_Id) return List_Id;
- -- Copy recursively a list of nodes using New_Copy_Separate_Tree
-
- function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id;
- -- Perform a deep copy of the subtree rooted at Source using New_Copy_Tree
- -- replacing entities of local declarations by new entities. This behavior
- -- is required by the backend to ensure entities uniqueness when a copy of
- -- a subtree is attached to the tree. The new entities keep their original
- -- names to facilitate debugging the tree copy.
-
function New_Copy_Tree
(Source : Node_Id;
Map : Elist_Id := No_Elist;