[Ada] Detection of illegal constituent assignments

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.

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.

From-SVN: r256520

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 415a42c3efa2653970cc0e4b261ef349d6052642..cd66210109ba12e8a6b485ea7c4f50a9d38dcd82 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2018-01-11  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * 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.
+
 2018-01-11  Arnaud Charlet  <charlet@adacore.com>
 
        Bump copyright notices to 2018.

diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 6d46d659f9e1a7c107d319d8ba4787f098408249..b94c9e8c17ba3787e35fde57375250d53e8ce92e 100644 (file)
--- a/gcc/ada/sem_ch5.adb
+++ b/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.

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e5d9ddea599122466158900dcaf24457b9ec439f..43dcbedcad3e730032f6f46f97377607f3132295 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-01-11  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * gnat.dg/protected_func.adb, gnat.dg/protected_func.ads: New testcase.
+
 2018-01-11  Justin Squirek  <squirek@adacore.com>
 
        * gnat.dg/expr_func4.adb: New testcase.

diff --git a/gcc/testsuite/gnat.dg/protected_func.adb b/gcc/testsuite/gnat.dg/protected_func.adb
new file mode 100644 (file)
index 0000000..f3eead4
--- /dev/null
+++ b/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;

diff --git a/gcc/testsuite/gnat.dg/protected_func.ads b/gcc/testsuite/gnat.dg/protected_func.ads
new file mode 100644 (file)
index 0000000..b9d5194
--- /dev/null
+++ b/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;