From 773e99ac3e61bd84f9848e78e17867a920f9ae53 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Thu, 12 Mar 2020 07:01:43 -0400 Subject: [PATCH] [Ada] Bad access checks on if/case expression as actual 2020-06-15 Justin Squirek gcc/ada/ * exp_ch4.adb (Expand_N_Case_Expression): Set default value for Target to silence potential warnings. (Expand_N_If_Expression): Add calculation to check when the if expression is used directly in the context of an actual of an anonymous access type and add a special path to force expansion of the if expression in this case. * exp_ch6.adb (Expand_Branch): Generate an assignment to the level temporary for a given branch. (Expand_Call_Helper): Add expansion to allow for creating a temporary to store associated accessiblity levels on each branch of the conditional expression. Also perform expansion of function calls into expressions with actions, and fixup references to N with Call_Node. (Insert_Level_Assign): Move through nested conditional expressions to each branch. * sem_util.ads, sem_util.adb (Is_Anonymous_Access_Actual): Added to detect when to force expansion of if expressions. --- gcc/ada/exp_ch4.adb | 86 +++++++++++++++++-- gcc/ada/exp_ch6.adb | 231 ++++++++++++++++++++++++++++++++++++++++++++++++--- gcc/ada/sem_util.adb | 22 +++++ gcc/ada/sem_util.ads | 4 + 4 files changed, 323 insertions(+), 20 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7a84215..bf88225 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5314,7 +5314,7 @@ package body Exp_Ch4 is Case_Stmt : Node_Id; Decl : Node_Id; Expr : Node_Id; - Target : Entity_Id; + Target : Entity_Id := Empty; Target_Typ : Entity_Id; In_Predicate : Boolean := False; @@ -5771,11 +5771,21 @@ package body Exp_Ch4 is Elsex : constant Node_Id := Next (Thenx); Typ : constant Entity_Id := Etype (N); - Actions : List_Id; - Decl : Node_Id; - Expr : Node_Id; - New_If : Node_Id; - New_N : Node_Id; + Actions : List_Id; + Decl : Node_Id; + Expr : Node_Id; + New_If : Node_Id; + New_N : Node_Id; + + -- Determine if we are dealing with a special case of a conditional + -- expression used as an actual for an anonymous access type which + -- forces us to transform the if expression into an expression with + -- actions in order to create a temporary to capture the level of the + -- expression in each branch. + + Force_Expand : constant Boolean := Is_Anonymous_Access_Actual (N); + + -- Start of processing for Expand_N_If_Expression begin -- Check for MINIMIZED/ELIMINATED overflow mode @@ -5975,9 +5985,13 @@ package body Exp_Ch4 is end; -- For other types, we only need to expand if there are other actions - -- associated with either branch. + -- associated with either branch or we need to force expansion to deal + -- with if expressions used as an actual of an anonymous access type. - elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then + elsif Present (Then_Actions (N)) + or else Present (Else_Actions (N)) + or else Force_Expand + then -- We now wrap the actions into the appropriate expression @@ -6051,6 +6065,62 @@ package body Exp_Ch4 is Analyze_And_Resolve (Elsex, Typ); end if; + -- We must force expansion into an expression with actions when + -- an if expression gets used directly as an actual for an + -- anonymous access type. + + if Force_Expand then + declare + Cnn : constant Entity_Id := Make_Temporary (Loc, 'C'); + Acts : List_Id; + begin + Acts := New_List; + + -- Generate: + -- Cnn : Ann; + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Cnn, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + Append_To (Acts, Decl); + + Set_No_Initialization (Decl); + + -- Generate: + -- if Cond then + -- Cnn := ; + -- else + -- Cnn := ; + -- end if; + + New_If := + Make_Implicit_If_Statement (N, + Condition => Relocate_Node (Cond), + Then_Statements => New_List ( + Make_Assignment_Statement (Sloc (Thenx), + Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), + Expression => Relocate_Node (Thenx))), + + Else_Statements => New_List ( + Make_Assignment_Statement (Sloc (Elsex), + Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), + Expression => Relocate_Node (Elsex)))); + Append_To (Acts, New_If); + + -- Generate: + -- do + -- ... + -- in Cnn end; + + Rewrite (N, + Make_Expression_With_Actions (Loc, + Expression => New_Occurrence_Of (Cnn, Loc), + Actions => Acts)); + Analyze_And_Resolve (N, Typ); + end; + end if; + return; end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index cb31ae9..e7d2ccc 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2645,7 +2645,7 @@ package body Exp_Ch6 is end loop; if not Is_Empty_List (Inv_Checks) then - Insert_Actions_After (N, Inv_Checks); + Insert_Actions_After (Call_Node, Inv_Checks); end if; end Add_View_Conversion_Invariants; @@ -2919,7 +2919,7 @@ package body Exp_Ch6 is Formal : Node_Id; begin - Actual := First (Parameter_Associations (N)); + Actual := First (Parameter_Associations (Call_Node)); Formal := First_Formal (Subp); while Present (Actual) and then Present (Formal) @@ -3610,10 +3610,215 @@ package body Exp_Ch6 is -- Prev_Orig denotes an original expression that has -- not been analyzed. + -- However, when the actual is wrapped in a conditional + -- expression we must add a local temporary to store the + -- level at each branch, and, possibly, expand the call + -- into an expression with actions. + when others => - Add_Extra_Actual - (Expr => Dynamic_Accessibility_Level (Prev), - EF => Get_Accessibility (Formal)); + if Nkind (Prev) = N_Expression_With_Actions + and then Nkind_In (Original_Node (Prev), + N_If_Expression, + N_Case_Expression) + then + declare + Decl : Node_Id; + Lvl : Entity_Id; + Res : Entity_Id; + Temp : Node_Id; + Typ : Node_Id; + + procedure Insert_Level_Assign (Branch : Node_Id); + -- Recursivly add assignment of the level temporary + -- on each branch while moving through nested + -- conditional expressions. + + ------------------------- + -- Insert_Level_Assign -- + ------------------------- + + procedure Insert_Level_Assign (Branch : Node_Id) is + + procedure Expand_Branch (Assn : Node_Id); + -- Perform expansion or iterate further within + -- nested conditionals. + + ------------------- + -- Expand_Branch -- + ------------------- + + procedure Expand_Branch (Assn : Node_Id) is + begin + pragma Assert (Nkind (Assn) = + N_Assignment_Statement); + + -- There are more nested conditional + -- expressions so we must go deeper. + + if Nkind (Expression (Assn)) = + N_Expression_With_Actions + then + Insert_Level_Assign (Expression (Assn)); + + -- Add the level assignment + + else + Insert_Before_And_Analyze (Assn, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of + (Lvl, Loc), + Expression => + Dynamic_Accessibility_Level + (Expression (Assn)))); + end if; + end Expand_Branch; + + Cond : Node_Id; + Alt : Node_Id; + + -- Start of processing for Insert_Level_Assign + + begin + -- Examine further nested condtionals + + pragma Assert (Nkind (Branch) = + N_Expression_With_Actions); + + -- Find the relevant statement in the actions + + Cond := First (Actions (Branch)); + loop + exit when Nkind_In (Cond, N_Case_Statement, + N_If_Statement); + + Next (Cond); + pragma Assert (Present (Cond)); + end loop; + + -- Iterate through if expression branches + + if Nkind (Cond) = N_If_Statement then + Expand_Branch (Last (Then_Statements (Cond))); + Expand_Branch (Last (Else_Statements (Cond))); + + -- Iterate through case alternatives + + elsif Nkind (Cond) = N_Case_Statement then + + Alt := First (Alternatives (Cond)); + while Present (Alt) loop + Expand_Branch (Last (Statements (Alt))); + + Next (Alt); + end loop; + end if; + end Insert_Level_Assign; + + -- Start of processing for cond expression case + + begin + -- Create declaration of a temporary to store the + -- accessibility level of each branch of the + -- conditional expression. + + Lvl := Make_Temporary (Loc, 'L'); + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Lvl, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc)); + + -- Install the declaration and perform necessary + -- expansion if we are dealing with a function + -- call. + + if Nkind (Call_Node) = + N_Procedure_Call_Statement + then + -- Generate: + -- Lvl : Natural; + -- Call ( + -- {do + -- If_Exp_Res : Typ; + -- if Cond then + -- Lvl := 0; -- Access level + -- If_Exp_Res := Exp; + -- ... + -- in If_Exp_Res end;}, + -- Lvl, + -- ... + -- ) + + Insert_Before_And_Analyze (Call_Node, Decl); + + -- A function call must be transformed into an + -- expression with actions. + + else + -- Generate: + -- do + -- Lvl : Natural; + -- in Call (do{ + -- If_Exp_Res : Typ + -- if Cond then + -- Lvl := 0; -- Access level + -- If_Exp_Res := Exp; + -- in If_Exp_Res end;}, + -- Lvl, + -- ... + -- ) + -- end; + + Res := Make_Temporary (Loc, 'R'); + Typ := Etype (Call_Node); + Temp := Relocate_Node (Call_Node); + + -- Perform the rewrite with the dummy + + Rewrite (Call_Node, + + Make_Expression_With_Actions (Loc, + Expression => New_Occurrence_Of (Res, Loc), + Actions => New_List ( + Decl, + + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Object_Definition => + New_Occurrence_Of (Typ, Loc))))); + + -- Analyze the expression with the dummy + + Analyze_And_Resolve (Call_Node, Typ); + + -- Properly set the expression and move our view + -- of the call node + + Set_Expression (Call_Node, Relocate_Node (Temp)); + Call_Node := Expression (Call_Node); + Remove (Next (Decl)); + end if; + + -- Decorate the conditional expression with + -- assignments to our level temporary. + + Insert_Level_Assign (Prev); + + -- Make our level temporary the passed actual + + Add_Extra_Actual + (Expr => New_Occurrence_Of (Lvl, Loc), + EF => Get_Accessibility (Formal)); + end; + + -- General case uncomplicated by conditional expressions + + else + Add_Extra_Actual + (Expr => Dynamic_Accessibility_Level (Prev), + EF => Get_Accessibility (Formal)); + end if; end case; end if; end if; @@ -3801,7 +4006,7 @@ package body Exp_Ch6 is -- generating spurious checks on complex expansion such as object -- initialization through an extension aggregate. - if Comes_From_Source (N) + if Comes_From_Source (Call_Node) and then Ekind (Formal) /= E_In_Parameter and then Nkind (Actual) = N_Type_Conversion then @@ -4313,7 +4518,7 @@ package body Exp_Ch6 is if Nkind (Name (Call_Node)) = N_Explicit_Dereference then - -- Handle case of access to protected subprogram type + -- Handle case of access to protected subprogram type if Is_Access_Protected_Subprogram_Type (Base_Type (Etype (Prefix (Name (Call_Node))))) @@ -4461,8 +4666,9 @@ package body Exp_Ch6 is -- back-end inlining is enabled). elsif Is_Inlinable_Expression_Function (Subp) then - Rewrite (N, New_Copy (Expression_Of_Expression_Function (Subp))); - Analyze (N); + Rewrite + (Call_Node, New_Copy (Expression_Of_Expression_Function (Subp))); + Analyze (Call_Node); return; -- Handle front-end inlining @@ -4533,7 +4739,7 @@ package body Exp_Ch6 is elsif Modify_Tree_For_C and then In_Same_Extended_Unit (Sloc (Bod), Loc) - and then Chars (Name (N)) = Name_uPostconditions + and then Chars (Name (Call_Node)) = Name_uPostconditions then Must_Inline := True; end if; @@ -4641,8 +4847,9 @@ package body Exp_Ch6 is N_Slice) and then (Ekind (Current_Scope) /= E_Loop - or else Nkind (Parent (N)) /= N_Function_Call - or else not Is_Build_In_Place_Function_Call (Parent (N))) + or else Nkind (Parent (Call_Node)) /= N_Function_Call + or else not Is_Build_In_Place_Function_Call + (Parent (Call_Node))) then Establish_Transient_Scope (Call_Node, Manage_Sec_Stack => True); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index fc1d902..203cada 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -14170,6 +14170,28 @@ package body Sem_Util is end if; end Invalid_Scalar_Value; + -------------------------------- + -- Is_Anonymous_Access_Actual -- + -------------------------------- + + function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean is + Par : Node_Id; + begin + if Ekind (Etype (N)) /= E_Anonymous_Access_Type then + return False; + end if; + + Par := Parent (N); + while Present (Par) + and then Nkind_In (Par, N_Case_Expression, + N_If_Expression, + N_Parameter_Association) + loop + Par := Parent (Par); + end loop; + return Nkind (Par) in N_Subprogram_Call; + end Is_Anonymous_Access_Actual; + ----------------------------- -- Is_Actual_Out_Parameter -- ----------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 5aac8b8..ebc9175 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1579,6 +1579,10 @@ package Sem_Util is -- pragma Initialize_Scalars or by the binder. Return an expression created -- at source location Loc, which denotes the invalid value. + function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean; + -- Determine if N is used as an actual for a call whose corresponding + -- formal is of an anonymous access type. + function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean; -- True if E is the constructed wrapper for an access_to_subprogram -- type with Pre/Postconditions. -- 2.7.4