From a0c94bd34a4ed6b8239d9a6d749ad5c94022acff Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Thu, 23 Jan 2020 13:12:11 -0500 Subject: [PATCH] [Ada] Missing accessibility check on access discriminant in extended return 2020-06-04 Justin Squirek gcc/ada/ * sem_ch6.adb (Check_Return_Obj_Accessibility): Change to Check_Return_Construct_Accessibility to better reflect its purpose. Add loop to properly obtain the object declaration from an expanded extended return statement and add calls to get the original node for associated values. Also, avoid checks when the return statement being examined comes from an internally generated function. --- gcc/ada/sem_ch6.adb | 61 ++++++++++++++++++++++++++++++++++------------------- 1 file changed, 39 insertions(+), 22 deletions(-) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index e723480..a01fe00 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -696,7 +696,7 @@ package body Sem_Ch6 is R_Type : constant Entity_Id := Etype (Scope_Id); -- Function result subtype - procedure Check_Return_Obj_Accessibility (Return_Stmt : Node_Id); + procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id); -- Apply legality rule of 6.5 (5.9) to the access discriminants of an -- aggregate in a return statement. @@ -704,24 +704,26 @@ package body Sem_Ch6 is -- 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_Return_Obj_Accessibility -- - ------------------------------------ + ------------------------------------------ + -- Check_Return_Construct_Accessibility -- + ------------------------------------------ - procedure Check_Return_Obj_Accessibility (Return_Stmt : Node_Id) is + procedure Check_Return_Construct_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; + Return_Con : Node_Id; begin - -- Only perform checks on record types with access discriminants + -- Only perform checks on record types with access discriminants and + -- non-internally generated functions. if not Is_Record_Type (R_Type) or else not Has_Discriminants (R_Type) + or else not Comes_From_Source (Return_Stmt) then return; end if; @@ -738,32 +740,47 @@ package body Sem_Ch6 is -- 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)); + -- Obtain the object definition from the expanded extended return - -- We could be looking at something that's been expanded with - -- an initialzation procedure which we can safely ignore. + Return_Con := First (Return_Object_Declarations (Return_Stmt)); + while Present (Return_Con) loop + -- Inspect the original node to avoid object declarations + -- expanded into renamings. - if Nkind (Return_Obj) /= N_Object_Declaration then - return; - end if; + if Nkind (Original_Node (Return_Con)) = N_Object_Declaration + and then Comes_From_Source (Original_Node (Return_Con)) + then + exit; + end if; + + Nlists.Next (Return_Con); + end loop; + + pragma Assert (Present (Return_Con)); + + -- Could be dealing with a renaming + + Return_Con := Original_Node (Return_Con); else - Return_Obj := Return_Stmt; + Return_Con := 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)) + if Nkind (Return_Con) = N_Object_Declaration + and then Nkind (Object_Definition (Return_Con)) = N_Subtype_Indication then - Assoc := First (Constraints - (Constraint (Object_Definition (Return_Obj)))); + Assoc := Original_Node + (First + (Constraints + (Constraint (Object_Definition (Return_Con))))); else -- Qualified expressions may be nested - Agg := Original_Node (Expression (Return_Obj)); + Agg := Original_Node (Expression (Return_Con)); while Nkind (Agg) = N_Qualified_Expression loop Agg := Original_Node (Expression (Agg)); end loop; @@ -896,7 +913,7 @@ package body Sem_Ch6 is end if; end if; end loop; - end Check_Return_Obj_Accessibility; + end Check_Return_Construct_Accessibility; ------------------------------------- -- Check_Return_Subtype_Indication -- @@ -1103,7 +1120,7 @@ package body Sem_Ch6 is Resolve (Expr, R_Type); Check_Limited_Return (N, Expr, R_Type); - Check_Return_Obj_Accessibility (N); + Check_Return_Construct_Accessibility (N); end if; -- RETURN only allowed in SPARK as the last statement in function @@ -1159,7 +1176,7 @@ package body Sem_Ch6 is Check_References (Stm_Entity); - Check_Return_Obj_Accessibility (N); + Check_Return_Construct_Accessibility (N); -- Check RM 6.5 (5.9/3) -- 2.7.4