From 07b7dc09b21d1a2f000f2861a87b017b764b38b4 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Mon, 1 Mar 2021 16:39:31 +0100 Subject: [PATCH] [Ada] Fix detection of volatile expressions in restricted contexts gcc/ada/ * sem_res.adb (Flag_Effectively_Volatile_Objects): Detect also allocators within restricted contexts and not just entity names. (Resolve_Actuals): Remove duplicated code for detecting restricted contexts; it is now exclusively done in Is_OK_Volatile_Context. (Resolve_Entity_Name): Adapt to new parameter of Is_OK_Volatile_Context. * sem_util.ads, sem_util.adb (Is_OK_Volatile_Context): Adapt to handle contexts both inside and outside of subprogram call actual parameters. (Within_Subprogram_Call): Remove; now handled by Is_OK_Volatile_Context itself and its parameter. --- gcc/ada/sem_res.adb | 72 ++++++++++++----------------------- gcc/ada/sem_util.adb | 105 +++++++++++++++++++++++++++++---------------------- gcc/ada/sem_util.ads | 15 ++++---- 3 files changed, 91 insertions(+), 101 deletions(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 69c3c13..4377f91 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3755,19 +3755,18 @@ package body Sem_Res is begin case Nkind (N) is - - -- Do not consider object name appearing in the prefix of - -- attribute Address as a read. - - when N_Attribute_Reference => - - -- Prefix of attribute Address denotes an object, program - -- unit, or label; none of them needs to be flagged here. - - if Attribute_Name (N) = Name_Address then - return Skip; + when N_Allocator => + if not Is_OK_Volatile_Context (Context => Parent (N), + Obj_Ref => N, + Check_Actuals => True) + then + Error_Msg_N + ("allocator cannot appear in this context" + & " (SPARK RM 7.1.3(10))", N); end if; + return Skip; + -- Do not consider nested function calls because they have -- already been processed during their own resolution. @@ -3780,6 +3779,10 @@ package body Sem_Res is if Present (Id) and then Is_Object (Id) and then Is_Effectively_Volatile_For_Reading (Id) + and then + not Is_OK_Volatile_Context (Context => Parent (N), + Obj_Ref => N, + Check_Actuals => True) then Error_Msg_N ("volatile object cannot appear in this context" @@ -3789,10 +3792,8 @@ package body Sem_Res is return Skip; when others => - null; + return OK; end case; - - return OK; end Flag_Object; procedure Flag_Objects is new Traverse_Proc (Flag_Object); @@ -4962,40 +4963,14 @@ package body Sem_Res is if SPARK_Mode = On and then Comes_From_Source (A) then - -- An effectively volatile object for reading may act as an - -- actual when the corresponding formal is of a non-scalar - -- effectively volatile type for reading (SPARK RM 7.1.3(10)). + -- Inspect the expression and flag each effectively volatile + -- object for reading as illegal because it appears within + -- an interfering context. Note that this is usually done + -- in Resolve_Entity_Name, but when the effectively volatile + -- object for reading appears as an actual in a call, the call + -- must be resolved first. - if not Is_Scalar_Type (F_Typ) - and then Is_Effectively_Volatile_For_Reading (F_Typ) - then - null; - - -- An effectively volatile object for reading may act as an - -- actual in a call to an instance of Unchecked_Conversion. - -- (SPARK RM 7.1.3(10)). - - elsif Is_Unchecked_Conversion_Instance (Nam) then - null; - - -- The actual denotes an object - - elsif Is_Effectively_Volatile_Object_For_Reading (A) then - Error_Msg_N - ("volatile object cannot act as actual in a call (SPARK " - & "RM 7.1.3(10))", A); - - -- Otherwise the actual denotes an expression. Inspect the - -- expression and flag each effectively volatile object - -- for reading as illegal because it apprears within an - -- interfering context. Note that this is usually done in - -- Resolve_Entity_Name, but when the effectively volatile - -- object for reading appears as an actual in a call, the - -- call must be resolved first. - - else - Flag_Effectively_Volatile_Objects (A); - end if; + Flag_Effectively_Volatile_Objects (A); -- An effectively volatile variable cannot act as an actual -- parameter in a procedure call when the variable has enabled @@ -7890,7 +7865,8 @@ package body Sem_Res is if Is_Object (E) and then Is_Effectively_Volatile_For_Reading (E) - and then not Is_OK_Volatile_Context (Par, N) + and then + not Is_OK_Volatile_Context (Par, N, Check_Actuals => False) then SPARK_Msg_N ("volatile object cannot appear in this context " diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 74637ec..68e9a08 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -18794,8 +18794,9 @@ package body Sem_Util is ---------------------------- function Is_OK_Volatile_Context - (Context : Node_Id; - Obj_Ref : Node_Id) return Boolean + (Context : Node_Id; + Obj_Ref : Node_Id; + Check_Actuals : Boolean) return Boolean is function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean; -- Determine whether an arbitrary node denotes a call to a protected @@ -18878,6 +18879,12 @@ package body Sem_Util is Func_Id := Id; while Present (Func_Id) and then Func_Id /= Standard_Standard loop if Ekind (Func_Id) in E_Function | E_Generic_Function then + + -- ??? This routine could just use Return_Applies_To, but it + -- is currently wrongly called by unanalyzed return statements + -- coming from expression functions. + pragma Assert (Func_Id = Return_Applies_To (Id)); + return Is_Volatile_Function (Func_Id); end if; @@ -18894,9 +18901,17 @@ package body Sem_Util is -- Start of processing for Is_OK_Volatile_Context begin + -- For actual parameters within explicit parameter associations switch + -- the context to the corresponding subprogram call. + + if Nkind (Context) = N_Parameter_Association then + return Is_OK_Volatile_Context (Context => Parent (Context), + Obj_Ref => Obj_Ref, + Check_Actuals => Check_Actuals); + -- The volatile object appears on either side of an assignment - if Nkind (Context) = N_Assignment_Statement then + elsif Nkind (Context) = N_Assignment_Statement then return True; -- The volatile object is part of the initialization expression of @@ -18914,7 +18929,7 @@ package body Sem_Util is -- function is volatile. if Is_Return_Object (Obj_Id) then - return Within_Volatile_Function (Obj_Id); + return Within_Volatile_Function (Scope (Obj_Id)); -- Otherwise this is a normal object initialization @@ -18965,8 +18980,9 @@ package body Sem_Util is N_Slice and then Prefix (Context) = Obj_Ref and then Is_OK_Volatile_Context - (Context => Parent (Context), - Obj_Ref => Context) + (Context => Parent (Context), + Obj_Ref => Context, + Check_Actuals => Check_Actuals) then return True; @@ -18998,8 +19014,9 @@ package body Sem_Util is | N_Unchecked_Type_Conversion and then Expression (Context) = Obj_Ref and then Is_OK_Volatile_Context - (Context => Parent (Context), - Obj_Ref => Context) + (Context => Parent (Context), + Obj_Ref => Context, + Check_Actuals => Check_Actuals) then return True; @@ -19014,17 +19031,43 @@ package body Sem_Util is elsif Within_Check (Context) then return True; - -- Assume that references to effectively volatile objects that appear - -- as actual parameters in a subprogram call are always legal. A full - -- legality check is done when the actuals are resolved (see routine - -- Resolve_Actuals). + -- References to effectively volatile objects that appear as actual + -- parameters in subprogram calls can be examined only after call itself + -- has been resolved. Before that, assume such references to be legal. - elsif Within_Subprogram_Call (Context) then - return True; + elsif Nkind (Context) in N_Subprogram_Call | N_Entry_Call_Statement then + if Check_Actuals then + declare + Call : Node_Id; + Formal : Entity_Id; + Subp : constant Entity_Id := Get_Called_Entity (Context); + begin + Find_Actual (Obj_Ref, Formal, Call); + pragma Assert (Call = Context); + + -- An effectively volatile object may act as an actual when the + -- corresponding formal is of a non-scalar effectively volatile + -- type (SPARK RM 7.1.3(10)). + + if not Is_Scalar_Type (Etype (Formal)) + and then Is_Effectively_Volatile_For_Reading (Etype (Formal)) + then + return True; + + -- An effectively volatile object may act as an actual in a + -- call to an instance of Unchecked_Conversion. (SPARK RM + -- 7.1.3(10)). - -- Otherwise the context is not suitable for an effectively volatile - -- object. + elsif Is_Unchecked_Conversion_Instance (Subp) then + return True; + else + return False; + end if; + end; + else + return True; + end if; else return False; end if; @@ -29538,36 +29581,6 @@ package body Sem_Util is return Scope_Within_Or_Same (Scope (E), S); end Within_Scope; - ---------------------------- - -- Within_Subprogram_Call -- - ---------------------------- - - function Within_Subprogram_Call (N : Node_Id) return Boolean is - Par : Node_Id; - - begin - -- Climb the parent chain looking for a function or procedure call - - Par := N; - while Present (Par) loop - if Nkind (Par) in N_Entry_Call_Statement - | N_Function_Call - | N_Procedure_Call_Statement - then - return True; - - -- Prevent the search from going too far - - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; - - Par := Parent (Par); - end loop; - - return False; - end Within_Subprogram_Call; - ---------------- -- Wrong_Type -- ---------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 904821a..b8ad382 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2117,11 +2117,16 @@ package Sem_Util is -- conversions and hence variables. function Is_OK_Volatile_Context - (Context : Node_Id; - Obj_Ref : Node_Id) return Boolean; + (Context : Node_Id; + Obj_Ref : Node_Id; + Check_Actuals : Boolean) return Boolean; -- Determine whether node Context denotes a "non-interfering context" (as -- defined in SPARK RM 7.1.3(10)) where volatile reference Obj_Ref can - -- safely reside. + -- safely reside. When examining references that might be located within + -- actual parameters of a subprogram call that has not been resolved yet, + -- Check_Actuals should be False; such references will be assumed to be + -- legal. They will need to be checked again after subprogram call has + -- been resolved. function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean; -- Determine whether aspect specification or pragma Item is one of the @@ -3285,10 +3290,6 @@ package Sem_Util is function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean; -- Returns True if entity E is declared within scope S - function Within_Subprogram_Call (N : Node_Id) return Boolean; - -- Determine whether arbitrary node N appears in an entry, function, or - -- procedure call. - procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id); -- Output error message for incorrectly typed expression. Expr is the node -- for the incorrectly typed construct (Etype (Expr) is the type found), -- 2.7.4