[Ada] Fix detection of volatile expressions in restricted contexts

Message ID 20210616084356.GA96024@adacore.com
State New
Headers show
Series
  • [Ada] Fix detection of volatile expressions in restricted contexts
Related show

Commit Message

Pierre-Marie de Rodat June 16, 2021, 8:43 a.m.
Detection of volatile expressions, i.e. references to volatile objects
and allocators, is done in two steps: first when analysing entity names
and allocators themselves (except when they occur within actual
parameters of subprogram calls) and then after the subprogram call has
been resolved (so that we know if such volatile expressions are allowed
by the type of the corresponding formal parameter).

However, conditions used in each of these steps were duplicated and thus
inconsistent. This is fixed by this patch, so now all the conditions are
in just one place (i.e. in Is_OK_Volatile_Context whose new parameter
Check_Actuals to examine expressions within subprogram call parameters).

Tested on x86_64-pc-linux-gnu, committed on trunk

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.

Patch

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
--- 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
--- 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
--- 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),