From 4c7e09908b732b93b74b49ad3eafda0198c1d1df Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Feb 2013 11:10:32 +0100 Subject: [PATCH] [multiple changes] 2013-02-06 Hristian Kirtchev * exp_ch4.adb (Expand_N_Expression_With_Actions): Rewritten. This routine should be able to properly detect controlled transient objects in its actions and generate the appropriate finalization actions. * exp_ch6.adb (Enclosing_Context): Removed. (Expand_Ctrl_Function_Call): Remove local subprogram and constant. Use routine Within_Case_Or_If_Expression to determine whether the lifetime of the function result must be extended to match that of the context. * exp_util.ads, exp_util.adb (Within_Case_Or_If_Expression): New routine. 2013-02-06 Ed Schonberg * sem_ch12.adb (Validate_Array_Type_Instance): Extend check for subtype matching of component type of formal array type, to avoid spurious error when component type is a separate actual in the instance, and there may be a discrepancy between private and full view of component type. From-SVN: r195790 --- gcc/ada/ChangeLog | 22 +++ gcc/ada/exp_ch4.adb | 374 +++++++++++++++++++++++++++++++++++++-------------- gcc/ada/exp_ch6.adb | 54 +------- gcc/ada/exp_util.adb | 37 +++++ gcc/ada/exp_util.ads | 5 +- gcc/ada/sem_ch12.adb | 14 +- 6 files changed, 352 insertions(+), 154 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 309f7e7..6cc022a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2013-02-06 Hristian Kirtchev + + * exp_ch4.adb (Expand_N_Expression_With_Actions): Rewritten. This + routine should be able to properly detect controlled transient + objects in its actions and generate the appropriate finalization + actions. + * exp_ch6.adb (Enclosing_Context): Removed. + (Expand_Ctrl_Function_Call): Remove local subprogram and + constant. Use routine Within_Case_Or_If_Expression to determine + whether the lifetime of the function result must be extended to + match that of the context. + * exp_util.ads, exp_util.adb (Within_Case_Or_If_Expression): New + routine. + +2013-02-06 Ed Schonberg + + * sem_ch12.adb (Validate_Array_Type_Instance): Extend check + for subtype matching of component type of formal array type, + to avoid spurious error when component type is a separate actual + in the instance, and there may be a discrepancy between private + and full view of component type. + 2013-02-06 Robert Dewar * s-dim.ads, clean.adb: Minor reformatting. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 70e2fcd..56b1d63 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -4984,145 +4984,317 @@ package body Exp_Ch4 is -------------------------------------- procedure Expand_N_Expression_With_Actions (N : Node_Id) is + In_Case_Or_If_Expression : constant Boolean := + Within_Case_Or_If_Expression (N); - procedure Process_Transient_Object (Decl : Node_Id); - -- Given the declaration of a controlled transient declared inside the - -- Actions list of an Expression_With_Actions, generate all necessary - -- types and hooks in order to properly finalize the transient. This - -- mechanism works in conjunction with Build_Finalizer. + function Process_Action (Act : Node_Id) return Traverse_Result; + -- Inspect and process a single action of an expression_with_actions - ------------------------------ - -- Process_Transient_Object -- - ------------------------------ + -------------------- + -- Process_Action -- + -------------------- + + function Process_Action (Act : Node_Id) return Traverse_Result is + procedure Process_Transient_Object (Obj_Decl : Node_Id); + -- Obj_Decl denotes the declaration of a transient controlled object. + -- Generate all necessary types and hooks to properly finalize the + -- result when the enclosing context is elaborated/evaluated. + + ------------------------------ + -- Process_Transient_Object -- + ------------------------------ + + procedure Process_Transient_Object (Obj_Decl : Node_Id) is + function Find_Enclosing_Context return Node_Id; + -- Find the context where the expression_with_actions appears + + ---------------------------- + -- Find_Enclosing_Context -- + ---------------------------- + + function Find_Enclosing_Context return Node_Id is + function Is_Body_Or_Unit (N : Node_Id) return Boolean; + -- Determine whether N denotes a body or unit declaration + + --------------------- + -- Is_Body_Or_Unit -- + --------------------- + + function Is_Body_Or_Unit (N : Node_Id) return Boolean is + begin + return Nkind_In (N, N_Entry_Body, + N_Package_Body, + N_Package_Declaration, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body); + end Is_Body_Or_Unit; + + -- Local variables + + Par : Node_Id; + Top : Node_Id; + + -- Start of processing for Find_Enclosing_Context + + begin + -- The expression_with_action is in a case or if expression and + -- the lifetime of any temporary controlled object is therefore + -- extended. Find a suitable insertion node by locating the top + -- most case or if expressions. + + if In_Case_Or_If_Expression then + Par := N; + Top := N; + while Present (Par) loop + if Nkind_In (Original_Node (Par), N_Case_Expression, + N_If_Expression) + then + Top := Par; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Unit (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + + -- The topmost case or if expression is now recovered, but + -- it may still not be the correct place to add all the + -- generated code. Climb to find a parent that is part of a + -- declarative or statement list. + + Par := Top; + while Present (Par) loop + if Is_List_Member (Par) + and then + not Nkind_In (Par, N_Component_Association, + N_Discriminant_Association, + N_Parameter_Association, + N_Pragma_Argument_Association) + then + return Par; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Unit (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + + return Par; + + -- Shor circuit operators in complex expressions are converted + -- into expression_with_actions. + + else + -- Take care of the case where the expression_with_actions + -- is burried deep inside an if statement. The temporary + -- function result must be finalized before the then, elsif + -- or else statements are evaluated. + + -- if Something + -- and then Ctrl_Func_Call + -- then + -- + -- + -- end if; + + -- To achieve this, find the topmost logical operator. The + -- generated actions are then inserted before/after it. + + Par := N; + while Present (Par) loop + + -- Keep climbing past various operators + + if Nkind (Parent (Par)) in N_Op + or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else) + then + Par := Parent (Par); + else + exit; + end if; + end loop; + + Top := Par; + + -- The expression_with_action might be located in a pragm + -- in which case locate the pragma itself: + + -- pragma Precondition (... and then Ctrl_Func_Call ...); + + -- Similar case occurs when the expression_with_actions is + -- related to an object declaration or assignment: + + -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...; - procedure Process_Transient_Object (Decl : Node_Id) is + while Present (Par) loop + if Nkind_In (Par, N_Assignment_Statement, + N_Object_Declaration, + N_Pragma) + then + return Par; + + elsif Is_Body_Or_Unit (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + + -- Return the topmost short circuit operator - function Find_Insertion_Node return Node_Id; - -- Complex conditions in if statements may be converted into nested - -- EWAs. In this case, any generated code must be inserted before the - -- if statement to ensure proper visibility of the hook objects. This - -- routine returns the top most short circuit operator or the parent - -- of the EWA if no nesting was detected. + return Top; + end if; + end Find_Enclosing_Context; + + -- Local variables - ------------------------- - -- Find_Insertion_Node -- - ------------------------- + Context : constant Node_Id := Find_Enclosing_Context; + Loc : constant Source_Ptr := Sloc (Obj_Decl); + Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); + Obj_Typ : constant Node_Id := Etype (Obj_Id); + Desig_Typ : Entity_Id; + Expr : Node_Id; + Ptr_Id : Entity_Id; + Temp_Id : Entity_Id; - function Find_Insertion_Node return Node_Id is - Par : Node_Id; + -- Start of processing for Process_Transient_Object begin - -- Climb up the branches of a complex condition + -- Step 1: Create the access type which provides a reference to + -- the transient object. - Par := N; - while Nkind_In (Parent (Par), N_And_Then, N_Op_Not, N_Or_Else) loop - Par := Parent (Par); - end loop; + if Is_Access_Type (Obj_Typ) then + Desig_Typ := Directly_Designated_Type (Obj_Typ); + else + Desig_Typ := Obj_Typ; + end if; - return Par; - end Find_Insertion_Node; + -- Generate: + -- Ann : access [all] ; - -- Local variables + Ptr_Id := Make_Temporary (Loc, 'A'); - Ins_Node : constant Node_Id := Find_Insertion_Node; - Loc : constant Source_Ptr := Sloc (Decl); - Obj_Id : constant Entity_Id := Defining_Identifier (Decl); - Obj_Typ : constant Entity_Id := Etype (Obj_Id); - Desig_Typ : Entity_Id; - Expr : Node_Id; - Ptr_Decl : Node_Id; - Ptr_Id : Entity_Id; - Temp_Decl : Node_Id; - Temp_Id : Node_Id; + Insert_Action (Context, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Id, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => + Ekind (Obj_Typ) = E_General_Access_Type, + Subtype_Indication => New_Reference_To (Desig_Typ, Loc)))); - -- Start of processing for Process_Transient_Object + -- Step 2: Create a temporary which acts as a hook to the + -- transient object. Generate: - begin - -- Step 1: Create the access type which provides a reference to the - -- transient object. + -- Temp : Ptr_Id := null; - if Is_Access_Type (Obj_Typ) then - Desig_Typ := Directly_Designated_Type (Obj_Typ); - else - Desig_Typ := Obj_Typ; - end if; + Temp_Id := Make_Temporary (Loc, 'T'); - -- Generate: - -- Ann : access [all] ; + Insert_Action (Context, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Object_Definition => New_Reference_To (Ptr_Id, Loc))); - Ptr_Id := Make_Temporary (Loc, 'A'); + -- Mark this temporary as created for the purposes of exporting + -- the transient declaration out of the Actions list. This signals + -- the machinery in Build_Finalizer to recognize this special + -- case. - Ptr_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ptr_Id, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => - Ekind (Obj_Typ) = E_General_Access_Type, - Subtype_Indication => New_Reference_To (Desig_Typ, Loc))); + Set_Status_Flag_Or_Transient_Decl (Temp_Id, Obj_Decl); - Insert_Action (Ins_Node, Ptr_Decl); - Analyze (Ptr_Decl); + -- Step 3: Hook the transient object to the temporary - -- Step 2: Create a temporary which acts as a hook to the transient - -- object. Generate: + if Is_Access_Type (Obj_Typ) then + Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc)); + else + Expr := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Obj_Id, Loc), + Attribute_Name => Name_Unrestricted_Access); + end if; - -- Temp : Ptr_Id := null; + -- Generate: + -- Temp := Ptr_Id (Obj_Id); + -- + -- Temp := Obj_Id'Unrestricted_Access; - Temp_Id := Make_Temporary (Loc, 'T'); + Insert_After_And_Analyze (Obj_Decl, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Temp_Id, Loc), + Expression => Expr)); - Temp_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp_Id, - Object_Definition => New_Reference_To (Ptr_Id, Loc)); + -- Step 4: Finalize the function result after the context has been + -- evaluated/elaborated. Generate: - Insert_Action (Ins_Node, Temp_Decl); - Analyze (Temp_Decl); + -- if Temp /= null then + -- [Deep_]Finalize (Temp.all); + -- Temp := null; + -- end if; - -- Mark this temporary as created for the purposes of exporting the - -- transient declaration out of the Actions list. This signals the - -- machinery in Build_Finalizer to recognize this special case. + Insert_Action_After (Context, + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Reference_To (Temp_Id, Loc), + Right_Opnd => Make_Null (Loc)), - Set_Status_Flag_Or_Transient_Decl (Temp_Id, Decl); + Then_Statements => New_List ( + Make_Final_Call + (Obj_Ref => + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp_Id, Loc)), + Typ => Desig_Typ), - -- Step 3: Hook the transient object to the temporary + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Temp_Id, Loc), + Expression => Make_Null (Loc))))); + end Process_Transient_Object; - if Is_Access_Type (Obj_Typ) then - Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc)); - else - Expr := - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Obj_Id, Loc), - Attribute_Name => Name_Unrestricted_Access); + -- Start of processing for Process_Action + + begin + if Nkind (Act) = N_Object_Declaration + and then Is_Finalizable_Transient (Act, N) + then + Process_Transient_Object (Act); + + -- Avoid processing temporary function results multiple times when + -- dealing with nested expression_with_actions. + + elsif Nkind (Act) = N_Expression_With_Actions then + return Abandon; + + -- Do not process temporary function results in loops. This is + -- done by Expand_N_Loop_Statement and Build_Finalizer. + + elsif Nkind (Act) = N_Loop_Statement then + return Abandon; end if; - -- Generate: - -- Temp := Ptr_Id (Obj_Id); - -- - -- Temp := Obj_Id'Unrestricted_Access; + return OK; + end Process_Action; - Insert_After_And_Analyze (Decl, - Make_Assignment_Statement (Loc, - Name => New_Reference_To (Temp_Id, Loc), - Expression => Expr)); - end Process_Transient_Object; + procedure Process_Single_Action is new Traverse_Proc (Process_Action); -- Local variables - Decl : Node_Id; + Act : Node_Id; -- Start of processing for Expand_N_Expression_With_Actions begin - Decl := First (Actions (N)); - while Present (Decl) loop - if Nkind (Decl) = N_Object_Declaration - and then Is_Finalizable_Transient (Decl, N) - then - Process_Transient_Object (Decl); - end if; + Act := First (Actions (N)); + while Present (Act) loop + Process_Single_Action (Act); - Next (Decl); + Next (Act); end loop; end Expand_N_Expression_With_Actions; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index cd83d45..a2caf15 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -4036,45 +4036,6 @@ package body Exp_Ch6 is ------------------------------- procedure Expand_Ctrl_Function_Call (N : Node_Id) is - function Enclosing_Context return Node_Id; - -- Find the enclosing context where the function call appears - - ----------------------- - -- Enclosing_Context -- - ----------------------- - - function Enclosing_Context return Node_Id is - Context : Node_Id; - - begin - Context := Parent (N); - while Present (Context) loop - - -- The following could use a comment (and why is N_Case_Expression - -- not treated in a similar manner ??? - - if Nkind (Context) = N_If_Expression then - exit; - - -- Stop the search when reaching any statement because we have - -- gone too far up the tree. - - elsif Nkind (Context) = N_Procedure_Call_Statement - or else Nkind (Context) in N_Statement_Other_Than_Procedure_Call - then - exit; - end if; - - Context := Parent (Context); - end loop; - - return Context; - end Enclosing_Context; - - -- Local variables - - Context : constant Node_Id := Enclosing_Context; - begin -- Optimization, if the returned value (which is on the sec-stack) is -- returned again, no need to copy/readjust/finalize, we can just pass @@ -4096,15 +4057,12 @@ package body Exp_Ch6 is Remove_Side_Effects (N); - -- The function call is part of an if expression dependent expression. - -- The temporary result must live as long as the if expression itself, - -- otherwise it will be finalized too early. Mark the transient as - -- processed to avoid untimely finalization. - - -- Why no special handling for case expressions here ??? + -- When the temporary function result appears inside a case or an if + -- expression, its lifetime must be extended to match that of the + -- context. If not, the function result would be finalized prematurely + -- and the evaluation of the expression could yield the wrong result. - if Present (Context) - and then Nkind (Context) = N_If_Expression + if Within_Case_Or_If_Expression (N) and then Nkind (N) = N_Explicit_Dereference then Set_Is_Processed_Transient (Entity (Prefix (N))); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 4e04ae8..3528fc9 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -7944,6 +7944,43 @@ package body Exp_Util is end if; end Type_May_Have_Bit_Aligned_Components; + ---------------------------------- + -- Within_Case_Or_If_Expression -- + ---------------------------------- + + function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is + Par : Node_Id; + + begin + -- Locate an enclosing case or if expression. Note that these constructs + -- appear as expression_with_actions, hence the test using the original + -- node. + + Par := N; + while Present (Par) loop + if Nkind_In (Original_Node (Par), N_Case_Expression, + N_If_Expression) + then + return True; + + -- Prevent the search from going too far + + elsif Nkind_In (Par, N_Entry_Body, + N_Package_Body, + N_Package_Declaration, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body) + then + return False; + end if; + + Par := Parent (Par); + end loop; + + return False; + end Within_Case_Or_If_Expression; + ---------------------------- -- Wrap_Cleanup_Procedure -- ---------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 339fd43..e0b0e09 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -818,6 +818,9 @@ package Exp_Util is -- is conservative, in that a result of False is decisive. A result of True -- means that such a component may or may not be present. + function Within_Case_Or_If_Expression (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N is within a case or an if expression + procedure Wrap_Cleanup_Procedure (N : Node_Id); -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call -- at the start of the statement sequence, and an Abort_Undefer call at the diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 85a863f..267d50c 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -10699,13 +10699,19 @@ package body Sem_Ch12 is -- issues when the generic is a child unit and some aspect of the -- generic type is declared in a parent unit of the generic. We do -- the test to handle this special case only after a direct check - -- for static matching has failed. + -- for static matching has failed. The case where both the component + -- type and the array type are separate formals, and the component + -- type is a private view may also require special checking. if Subtypes_Match (Component_Type (A_Gen_T), Component_Type (Act_T)) or else Subtypes_Match - (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), - Component_Type (Act_T)) + (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), + Component_Type (Act_T)) + or else Subtypes_Match + (Base_Type + (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T)), + Component_Type (Act_T)) then null; else -- 2.7.4