From: Javier Miranda Date: Wed, 4 Mar 2020 19:22:44 +0000 (-0500) Subject: [Ada] Crash on dispatching conditional entry call X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8c1bec899afc30d4338a6953ede396bfcdd1dce0;p=gcc.git [Ada] Crash on dispatching conditional entry call 2020-06-11 Javier Miranda gcc/ada/ * exp_ch9.adb (Expand_N_Conditional_Entry_Call): Replace call to New_Copy_List by calls to the new routine New_Copy_Separate_List. * sem_util.ads (New_Copy_Separate_List, New_Copy_Separate_Tree): New routines. * sem_util.adb (New_Copy_Separate_List, New_Copy_Separate_Tree): New routines. (New_Copy_Tree): Extend the machinery that detects syntactic nodes to handle lists of indentifiers with field More_Ids; otherwise such nodes are erroneously handled as semantic nodes. Copy aspect specifications attached to nodes. * sem_ch12.adb (Copy_Generic_Node): Protect reading attribute Etype. --- diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 4c2af03efe2..49d3c1f324b 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -8124,7 +8124,7 @@ package body Exp_Ch9 is -- -- end if; - N_Stats := New_Copy_List_Tree (Statements (Alt)); + N_Stats := New_Copy_Separate_List (Statements (Alt)); Prepend_To (N_Stats, Make_Implicit_If_Statement (N, @@ -8168,7 +8168,7 @@ package body Exp_Ch9 is -- ; -- - Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt)); + Lim_Typ_Stmts := New_Copy_Separate_List (Statements (Alt)); Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); -- Generate: diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 80a8246b3a6..93a3ca59d5c 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -8098,6 +8098,7 @@ package body Sem_Ch12 is elsif Nkind (Assoc) = N_Identifier and then Nkind (Parent (Assoc)) = N_Type_Conversion and then Subtype_Mark (Parent (Assoc)) = Assoc + and then Present (Etype (Assoc)) and then Is_Access_Type (Etype (Assoc)) and then Present (Etype (Expression (Parent (Assoc)))) and then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 92dd39452d1..cce55a6c58a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -20323,6 +20323,118 @@ 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 + if No (Decls) then + Decls := New_Elmt_List; + end if; + + Append_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_Defining_Identifier (Sloc (Decl), + New_Internal_Name ('P')); + + if Nkind (Decl) = N_Expression_Function then + Decl := Specification (Decl); + end if; + + if Nkind_In (Decl, 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 -- ------------------- @@ -20751,6 +20863,65 @@ package body Sem_Util is New_Par : Node_Id := Empty; Semantic : Boolean := False) return Union_Id is + function Has_More_Ids (N : Node_Id) return Boolean; + -- Return True when N has attribute More_Ids set to True + + function Is_Syntactic_Node return Boolean; + -- Return True when Field is a syntactic node + + ------------------ + -- Has_More_Ids -- + ------------------ + + function Has_More_Ids (N : Node_Id) return Boolean is + begin + if Nkind_In (N, N_Component_Declaration, + N_Discriminant_Specification, + N_Exception_Declaration, + N_Formal_Object_Declaration, + N_Number_Declaration, + N_Object_Declaration, + N_Parameter_Specification, + N_Use_Package_Clause, + N_Use_Type_Clause) + then + return More_Ids (N); + else + return False; + end if; + end Has_More_Ids; + + ----------------------- + -- Is_Syntactic_Node -- + ----------------------- + + function Is_Syntactic_Node return Boolean is + Old_N : constant Node_Id := Node_Id (Field); + + begin + if Parent (Old_N) = Old_Par then + return True; + + elsif not Has_More_Ids (Old_Par) then + return False; + + -- Perform the check using the last last id in the syntactic chain + + else + declare + N : Node_Id := Old_Par; + + begin + while Present (N) and then More_Ids (N) loop + Next (N); + end loop; + + pragma Assert (Prev_Ids (N)); + return Parent (Old_N) = N; + end; + end if; + end Is_Syntactic_Node; + begin -- The field is empty @@ -20762,7 +20933,7 @@ package body Sem_Util is elsif Field in Node_Range then declare Old_N : constant Node_Id := Node_Id (Field); - Syntactic : constant Boolean := Parent (Old_N) = Old_Par; + Syntactic : constant Boolean := Is_Syntactic_Node; New_N : Node_Id; @@ -20990,6 +21161,11 @@ package body Sem_Util is Set_Chars (Result, Chars (Entity (Result))); end if; end if; + + if Has_Aspects (N) then + Set_Aspect_Specifications (Result, + Copy_List_With_Replacement (Aspect_Specifications (N))); + end if; end if; return Result; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e477c3849bb..b794e809822 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2291,6 +2291,16 @@ 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;