diff options
Diffstat (limited to 'gcc/ada/sem_res.adb')
| -rw-r--r-- | gcc/ada/sem_res.adb | 180 |
1 files changed, 6 insertions, 174 deletions
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index e88e551cb2e..95080c3f947 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -28,7 +28,6 @@ with Checks; use Checks; with Debug; use Debug; with Debug_A; use Debug_A; with Einfo; use Einfo; -with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; with Exp_Disp; use Exp_Disp; @@ -4020,40 +4019,6 @@ package body Sem_Res is -- If the allocator is an actual in a call, it is allowed to be class- -- wide when the context is not because it is a controlling actual. - procedure Propagate_Coextensions (Root : Node_Id); - -- Propagate all nested coextensions which are located one nesting - -- level down the tree to the node Root. Example: - -- - -- Top_Record - -- Level_1_Coextension - -- Level_2_Coextension - -- - -- The algorithm is paired with delay actions done by the Expander. In - -- the above example, assume all coextensions are controlled types. - -- The cycle of analysis, resolution and expansion will yield: - -- - -- 1) Analyze Top_Record - -- 2) Analyze Level_1_Coextension - -- 3) Analyze Level_2_Coextension - -- 4) Resolve Level_2_Coextension. The allocator is marked as a - -- coextension. - -- 5) Expand Level_2_Coextension. A temporary variable Temp_1 is - -- generated to capture the allocated object. Temp_1 is attached - -- to the coextension chain of Level_2_Coextension. - -- 6) Resolve Level_1_Coextension. The allocator is marked as a - -- coextension. A forward tree traversal is performed which finds - -- Level_2_Coextension's list and copies its contents into its - -- own list. - -- 7) Expand Level_1_Coextension. A temporary variable Temp_2 is - -- generated to capture the allocated object. Temp_2 is attached - -- to the coextension chain of Level_1_Coextension. Currently, the - -- contents of the list are [Temp_2, Temp_1]. - -- 8) Resolve Top_Record. A forward tree traversal is performed which - -- finds Level_1_Coextension's list and copies its contents into - -- its own list. - -- 9) Expand Top_Record. Generate finalization calls for Temp_1 and - -- Temp_2 and attach them to Top_Record's finalization list. - ------------------------------------------- -- Check_Allocator_Discrim_Accessibility -- ------------------------------------------- @@ -4107,140 +4072,14 @@ package body Sem_Res is function In_Dispatching_Context return Boolean is Par : constant Node_Id := Parent (N); - begin - return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement) - and then Is_Entity_Name (Name (Par)) - and then Is_Dispatching_Operation (Entity (Name (Par))); - end In_Dispatching_Context; - - ---------------------------- - -- Propagate_Coextensions -- - ---------------------------- - - procedure Propagate_Coextensions (Root : Node_Id) is - - procedure Copy_List (From : Elist_Id; To : Elist_Id); - -- Copy the contents of list From into list To, preserving the - -- order of elements. - - function Process_Allocator (Nod : Node_Id) return Traverse_Result; - -- Recognize an allocator or a rewritten allocator node and add it - -- along with its nested coextensions to the list of Root. - - --------------- - -- Copy_List -- - --------------- - - procedure Copy_List (From : Elist_Id; To : Elist_Id) is - From_Elmt : Elmt_Id; - begin - From_Elmt := First_Elmt (From); - while Present (From_Elmt) loop - Append_Elmt (Node (From_Elmt), To); - Next_Elmt (From_Elmt); - end loop; - end Copy_List; - - ----------------------- - -- Process_Allocator -- - ----------------------- - - function Process_Allocator (Nod : Node_Id) return Traverse_Result is - Orig_Nod : Node_Id := Nod; - - begin - -- This is a possible rewritten subtype indication allocator. Any - -- nested coextensions will appear as discriminant constraints. - - if Nkind (Nod) = N_Identifier - and then Present (Original_Node (Nod)) - and then Nkind (Original_Node (Nod)) = N_Subtype_Indication - then - declare - Discr : Node_Id; - Discr_Elmt : Elmt_Id; - - begin - if Is_Record_Type (Entity (Nod)) then - Discr_Elmt := - First_Elmt (Discriminant_Constraint (Entity (Nod))); - while Present (Discr_Elmt) loop - Discr := Node (Discr_Elmt); - - if Nkind (Discr) = N_Identifier - and then Present (Original_Node (Discr)) - and then Nkind (Original_Node (Discr)) = N_Allocator - and then Present (Coextensions ( - Original_Node (Discr))) - then - if No (Coextensions (Root)) then - Set_Coextensions (Root, New_Elmt_List); - end if; - - Copy_List - (From => Coextensions (Original_Node (Discr)), - To => Coextensions (Root)); - end if; - - Next_Elmt (Discr_Elmt); - end loop; - - -- There is no need to continue the traversal of this - -- subtree since all the information has already been - -- propagated. - - return Skip; - end if; - end; - - -- Case of either a stand alone allocator or a rewritten allocator - -- with an aggregate. - - else - if Present (Original_Node (Nod)) then - Orig_Nod := Original_Node (Nod); - end if; - - if Nkind (Orig_Nod) = N_Allocator then - - -- Propagate the list of nested coextensions to the Root - -- allocator. This is done through list copy since a single - -- allocator may have multiple coextensions. Do not touch - -- coextensions roots. - - if not Is_Coextension_Root (Orig_Nod) - and then Present (Coextensions (Orig_Nod)) - then - if No (Coextensions (Root)) then - Set_Coextensions (Root, New_Elmt_List); - end if; - - Copy_List - (From => Coextensions (Orig_Nod), - To => Coextensions (Root)); - end if; - - -- There is no need to continue the traversal of this - -- subtree since all the information has already been - -- propagated. - - return Skip; - end if; - end if; - - -- Keep on traversing, looking for the next allocator - - return OK; - end Process_Allocator; - - procedure Process_Allocators is - new Traverse_Proc (Process_Allocator); - - -- Start of processing for Propagate_Coextensions begin - Process_Allocators (Expression (Root)); - end Propagate_Coextensions; + return + Nkind_In (Par, N_Function_Call, + N_Procedure_Call_Statement) + and then Is_Entity_Name (Name (Par)) + and then Is_Dispatching_Operation (Entity (Name (Par))); + end In_Dispatching_Context; -- Start of processing for Resolve_Allocator @@ -4487,13 +4326,6 @@ package body Sem_Res is Set_Is_Dynamic_Coextension (N, False); Set_Is_Static_Coextension (N, False); end if; - - -- There is no need to propagate any nested coextensions if they - -- are marked as static since they will be rewritten on the spot. - - if not Is_Static_Coextension (N) then - Propagate_Coextensions (N); - end if; end if; end Resolve_Allocator; |