mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-21 04:50:24 +08:00
Code Issues Packages Projects Releases Wiki Activity

[Ada] Missing accessibility check on access discriminant in extended return

Browse Source 
2020-06-04  Justin Squirek  <squirek@adacore.com>

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.
This commit is contained in:
Justin Squirek 2020-01-23 13:12:11 -05:00 committed by Pierre-Marie de Rodat
parent 7c02e403d1
commit a0c94bd34a
1 changed files with 39 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
gcc/ada/sem_ch6.adb
View File

@ -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)