[Ada] Detection of illegal constituent assignments

Message ID 20180111091356.GA105310@adacore.com
State New
Headers show
Series
  • [Ada] Detection of illegal constituent assignments
Related show

Commit Message

Pierre-Marie de Rodat Jan. 11, 2018, 9:13 a.m.
This patch modifies the analysis of assignment statements to detect an illegal
attempt to alter the value of single protected type Part_Of constituent when
inside a protected function.

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

2018-01-11  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* sem_ch5.adb (Analyze_Assignment): Assignments to variables that act
	as Part_Of consituents of single protected types are illegal when they
	take place inside a protected function.
	(Diagnose_Non_Variable_Lhs): Use Within_Function to check for an
	enclosing function.
	(Is_Protected_Part_Of_Constituent): New routine.
	(Within_Function): New routine.

gcc/testsuite/

	* gnat.dg/protected_func.adb, gnat.dg/protected_func.ads: New testcase.

Patch

--- gcc/ada/sem_ch5.adb
+++ gcc/ada/sem_ch5.adb
@@ -107,6 +107,11 @@  package body Sem_Ch5 is
       --  N is the node for the left hand side of an assignment, and it is not
       --  a variable. This routine issues an appropriate diagnostic.
 
+      function Is_Protected_Part_Of_Constituent
+        (Nod : Node_Id) return Boolean;
+      --  Determine whether arbitrary node Nod denotes a Part_Of constituent of
+      --  a single protected type.
+
       procedure Kill_Lhs;
       --  This is called to kill current value settings of a simple variable
       --  on the left hand side. We call it if we find any error in analyzing
@@ -141,6 +146,10 @@  package body Sem_Ch5 is
       --  assignment statements that are really initializations. These are
       --  marked No_Ctrl_Actions.
 
+      function Within_Function return Boolean;
+      --  Determine whether the current scope is a function or appears within
+      --  one.
+
       -------------------------------
       -- Diagnose_Non_Variable_Lhs --
       -------------------------------
@@ -170,11 +179,7 @@  package body Sem_Ch5 is
                --  of single protected types, the private component appears
                --  directly.
 
-               elsif (Is_Prival (Ent)
-                       and then
-                         (Ekind (Current_Scope) = E_Function
-                           or else Ekind (Enclosing_Dynamic_Scope
-                                            (Current_Scope)) = E_Function))
+               elsif (Is_Prival (Ent) and then Within_Function)
                    or else
                      (Ekind (Ent) = E_Component
                        and then Is_Protected_Type (Scope (Ent)))
@@ -222,6 +227,39 @@  package body Sem_Ch5 is
          Error_Msg_N ("left hand side of assignment must be a variable", N);
       end Diagnose_Non_Variable_Lhs;
 
+      --------------------------------------
+      -- Is_Protected_Part_Of_Constituent --
+      --------------------------------------
+
+      function Is_Protected_Part_Of_Constituent
+        (Nod : Node_Id) return Boolean
+      is
+         Encap_Id : Entity_Id;
+         Var_Id   : Entity_Id;
+
+      begin
+         --  Abstract states and variables may act as Part_Of constituents of
+         --  single protected types, however only variables can be modified by
+         --  an assignment.
+
+         if Is_Entity_Name (Nod) then
+            Var_Id := Entity (Nod);
+
+            if Present (Var_Id) and then Ekind (Var_Id) = E_Variable then
+               Encap_Id := Encapsulating_State (Var_Id);
+
+               --  To qualify, the node must denote a reference to a variable
+               --  whose encapsulating state is a single protected object.
+
+               return
+                 Present (Encap_Id)
+                   and then Is_Single_Protected_Object (Encap_Id);
+            end if;
+         end if;
+
+         return False;
+      end Is_Protected_Part_Of_Constituent;
+
       --------------
       -- Kill_Lhs --
       --------------
@@ -386,6 +424,24 @@  package body Sem_Ch5 is
          Insert_Action (N, Obj_Decl);
       end Transform_BIP_Assignment;
 
+      ---------------------
+      -- Within_Function --
+      ---------------------
+
+      function Within_Function return Boolean is
+         Scop_Id : constant Entity_Id := Current_Scope;
+
+      begin
+         if Ekind (Scop_Id) = E_Function then
+            return True;
+
+         elsif Ekind (Enclosing_Dynamic_Scope (Scop_Id)) = E_Function then
+            return True;
+         end if;
+
+         return False;
+      end Within_Function;
+
       --  Local variables
 
       T1 : Entity_Id;
@@ -713,6 +769,15 @@  package body Sem_Ch5 is
            ("target of assignment operation must not be abstract", Lhs);
       end if;
 
+      --  Variables which are Part_Of constituents of single protected types
+      --  behave in similar fashion to protected components. Such variables
+      --  cannot be modified by protected functions.
+
+      if Is_Protected_Part_Of_Constituent (Lhs) and then Within_Function then
+         Error_Msg_N
+           ("protected function cannot modify protected object", Lhs);
+      end if;
+
       --  Resolution may have updated the subtype, in case the left-hand side
       --  is a private protected component. Use the correct subtype to avoid
       --  scoping issues in the back-end.--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/protected_func.adb
@@ -0,0 +1,13 @@ 
+--  { dg-do compile }
+
+package body Protected_Func with SPARK_Mode is
+   protected body Prot_Obj is
+      function Prot_Func return Integer is
+      begin
+         Comp := Comp + 1;  --  { dg-error "protected function cannot modify protected object" }
+         Part_Of_Constit := Part_Of_Constit + 1;  --  { dg-error "protected function cannot modify protected object" }
+
+         return Comp + Part_Of_Constit;
+      end Prot_Func;
+   end Prot_Obj;
+end Protected_Func;--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/protected_func.ads
@@ -0,0 +1,9 @@ 
+package Protected_Func with SPARK_Mode is
+   protected Prot_Obj is
+      function Prot_Func return Integer;
+   private
+      Comp : Integer := 0;
+   end Prot_Obj;
+
+   Part_Of_Constit : Integer := 0 with Part_Of => Prot_Obj;
+end Protected_Func;