This patch corrects an issue in the compiler whereby conditional
expressions used directly as actuals for anonymous access types caused
the callee to fail to generate relevant accessibility checks.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-15 Justin Squirek <squi...@adacore.com>
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
+++ 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 := <Thenx>;
+ -- else
+ -- Cnn := <Elsex>;
+ -- 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;
--- gcc/ada/exp_ch6.adb
+++ 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;
--- gcc/ada/sem_util.adb
+++ 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 --
-----------------------------
--- gcc/ada/sem_util.ads
+++ 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.
