From d4a45898bc44a87f076485da44912df8c461bc64 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Wed, 18 Dec 2019 07:16:22 +0000 Subject: [PATCH] [Ada] Missing accessibility check on access discriminants 2019-12-18 Justin Squirek gcc/ada/ * sem_ch6.adb (Analyze_Function_Return): Modify handling of extended return statements to check accessibility of access discriminants. (Check_Aggregate_Accessibility): Removed. (Check_Return_Obj_Accessibility): Added to centralize checking of return aggregates and subtype indications in the case of an extended return statement. From-SVN: r279518 --- gcc/ada/ChangeLog | 10 +++ gcc/ada/sem_ch6.adb | 222 +++++++++++++++++++++++++++++++++++++++++----------- 2 files changed, 186 insertions(+), 46 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 465f5a9..aa37e62 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2019-12-18 Justin Squirek + + * sem_ch6.adb (Analyze_Function_Return): Modify handling of + extended return statements to check accessibility of access + discriminants. + (Check_Aggregate_Accessibility): Removed. + (Check_Return_Obj_Accessibility): Added to centralize checking + of return aggregates and subtype indications in the case of an + extended return statement. + 2019-12-18 Arnaud Charlet * libgnat/s-regpat.adb (Parse_Literal, Parse_Piece): Ensure diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 4afcf01..eca0557 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -694,69 +694,199 @@ package body Sem_Ch6 is R_Type : constant Entity_Id := Etype (Scope_Id); -- Function result subtype - procedure Check_Aggregate_Accessibility (Aggr : Node_Id); - -- Apply legality rule of 6.5 (5.8) to the access discriminants of an + procedure Check_Return_Obj_Accessibility (Return_Stmt : Node_Id); + -- Apply legality rule of 6.5 (5.9) to the access discriminants of an -- aggregate in a return statement. procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id); -- Check that the return_subtype_indication properly matches the result -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2). - ----------------------------------- - -- Check_Aggregate_Accessibility -- - ----------------------------------- + ------------------------------------ + -- Check_Return_Obj_Accessibility -- + ------------------------------------ - procedure Check_Aggregate_Accessibility (Aggr : Node_Id) is - Typ : constant Entity_Id := Etype (Aggr); - Assoc : Node_Id; - Discr : Entity_Id; - Expr : Node_Id; - Obj : Node_Id; + procedure Check_Return_Obj_Accessibility (Return_Stmt : Node_Id) is + Assoc : Node_Id; + Agg : Node_Id := Empty; + Discr : Entity_Id; + Expr : Node_Id; + Obj : Node_Id; + Process_Exprs : Boolean := False; + Return_Obj : Node_Id; begin - if Is_Record_Type (Typ) and then Has_Discriminants (Typ) then - Discr := First_Discriminant (Typ); - Assoc := First (Component_Associations (Aggr)); - while Present (Discr) loop - if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then + -- Only perform checks on record types with access discriminants + + if not Is_Record_Type (R_Type) + or else not Has_Discriminants (R_Type) + then + return; + end if; + + -- We are only interested in return statements + + if not Nkind_In (Return_Stmt, N_Extended_Return_Statement, + N_Simple_Return_Statement) + then + return; + end if; + + -- Fetch the object from the return statement, in the case of a + -- simple return statement the expression is part of the node. + + if Nkind (Return_Stmt) = N_Extended_Return_Statement then + Return_Obj := Last (Return_Object_Declarations (Return_Stmt)); + + -- We could be looking at something that's been expanded with + -- an initialzation procedure which we can safely ignore. + + if Nkind (Return_Obj) /= N_Object_Declaration then + return; + end if; + else + Return_Obj := Return_Stmt; + end if; + + -- We may need to check an aggregate or a subtype indication + -- depending on how the discriminants were specified and whether + -- we are looking at an extended return statement. + + if Nkind (Return_Obj) = N_Object_Declaration + and then Nkind (Object_Definition (Return_Obj)) + = N_Subtype_Indication + then + Assoc := First (Constraints + (Constraint (Object_Definition (Return_Obj)))); + else + -- Qualified expressions may be nested + + Agg := Original_Node (Expression (Return_Obj)); + while Nkind (Agg) = N_Qualified_Expression loop + Agg := Original_Node (Expression (Agg)); + end loop; + + -- If we are looking at an aggregate instead of a function call we + -- can continue checking accessibility for the supplied + -- discriminant associations. + + if Nkind (Agg) = N_Aggregate then + if Present (Expressions (Agg)) then + Assoc := First (Expressions (Agg)); + Process_Exprs := True; + else + Assoc := First (Component_Associations (Agg)); + end if; + + -- Otherwise the expression is not of interest ??? + + else + return; + end if; + end if; + + -- Move through the discriminants checking the accessibility level + -- of each co-extension's associated expression. + + Discr := First_Discriminant (R_Type); + while Present (Discr) loop + if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then + + if Nkind (Assoc) = N_Attribute_Reference then + Expr := Assoc; + elsif Nkind_In (Assoc, N_Component_Association, + N_Discriminant_Association) + then Expr := Expression (Assoc); + end if; - if Nkind (Expr) = N_Attribute_Reference - and then Attribute_Name (Expr) /= Name_Unrestricted_Access - then - Obj := Prefix (Expr); - while Nkind_In (Obj, N_Indexed_Component, - N_Selected_Component) - loop + -- This anonymous access discriminant has an associated + -- expression which needs checking. + + if Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) /= Name_Unrestricted_Access + then + -- Obtain the object to perform static checks on by moving + -- up the prefixes in the expression taking into account + -- named access types. + + Obj := Prefix (Expr); + while Nkind_In (Obj, N_Indexed_Component, + N_Selected_Component) + loop + -- When we encounter a named access type then we can + -- ignore accessibility checks on the dereference. + + if Ekind (Etype (Prefix (Obj))) + in E_Access_Type .. + E_Access_Protected_Subprogram_Type + then + if Nkind (Obj) = N_Selected_Component then + Obj := Selector_Name (Obj); + end if; + exit; + end if; + + -- Skip over the explicit dereference + + if Nkind (Prefix (Obj)) = N_Explicit_Dereference then + Obj := Prefix (Prefix (Obj)); + + -- Otherwise move up to the next prefix + + else Obj := Prefix (Obj); - end loop; + end if; + end loop; - -- Do not check aliased formals or function calls. A - -- run-time check may still be needed ??? + -- Do not check aliased formals or function calls. A + -- run-time check may still be needed ??? - if Is_Entity_Name (Obj) - and then Comes_From_Source (Obj) + if Is_Entity_Name (Obj) + and then Comes_From_Source (Obj) + then + -- Explicitly aliased formals are allowed + + if Is_Formal (Entity (Obj)) + and then Is_Aliased (Entity (Obj)) then - if Is_Formal (Entity (Obj)) - and then Is_Aliased (Entity (Obj)) - then - null; + null; - elsif Object_Access_Level (Obj) > - Scope_Depth (Scope (Scope_Id)) - then - Error_Msg_N - ("access discriminant in return aggregate would " - & "be a dangling reference", Obj); - end if; + elsif Object_Access_Level (Obj) > + Scope_Depth (Scope (Scope_Id)) + then + Error_Msg_N + ("access discriminant in return aggregate would " + & "be a dangling reference", Obj); end if; end if; end if; + end if; - Next_Discriminant (Discr); - end loop; - end if; - end Check_Aggregate_Accessibility; + Next_Discriminant (Discr); + + if not Is_List_Member (Assoc) then + Assoc := Empty; + else + Nlists.Next (Assoc); + end if; + + -- After aggregate expressions, examine component associations if + -- present. + + if No (Assoc) then + if Present (Agg) + and then Process_Exprs + and then Present (Component_Associations (Agg)) + then + Assoc := First (Component_Associations (Agg)); + Process_Exprs := False; + else + exit; + end if; + end if; + end loop; + end Check_Return_Obj_Accessibility; ------------------------------------- -- Check_Return_Subtype_Indication -- @@ -963,9 +1093,7 @@ package body Sem_Ch6 is Resolve (Expr, R_Type); Check_Limited_Return (N, Expr, R_Type); - if Present (Expr) and then Nkind (Expr) = N_Aggregate then - Check_Aggregate_Accessibility (Expr); - end if; + Check_Return_Obj_Accessibility (N); end if; -- RETURN only allowed in SPARK as the last statement in function @@ -1021,6 +1149,8 @@ package body Sem_Ch6 is Check_References (Stm_Entity); + Check_Return_Obj_Accessibility (N); + -- Check RM 6.5 (5.9/3) if Has_Aliased then -- 2.7.4