diff mbox series

[Ada] Volatility, validity checks, and System.Aux_DEC

Message ID 20181211113641.GA106016@adacore.com
State New
Headers show
Series [Ada] Volatility, validity checks, and System.Aux_DEC | expand

Commit Message

Pierre-Marie de Rodat Dec. 11, 2018, 11:36 a.m. UTC 
This patch updates validity checks to prevent the validation of an
by-reference formal parameter because the parameter is not being read in
the process.

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

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

gcc/ada/

	* checks.adb: Add with and use clauses for Sem_Mech.
	(Ensure_Valid): Update the "annoying special case" to include
	entry and function calls. Use Get_Called_Entity to obtain the
	entry or subprogram being invoked, rather than retrieving it
	manually. Parameters passed by reference do not need a validity
	check.

gcc/testsuite/

	* gnat.dg/valid4.adb, gnat.dg/valid4_pkg.adb,
	gnat.dg/valid4_pkg.ads: New testcase.
diff mbox series

Patch

--- gcc/ada/checks.adb
+++ gcc/ada/checks.adb
@@ -50,6 +50,7 @@  with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Disp; use Sem_Disp;
 with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
 with Sem_Warn; use Sem_Warn;
@@ -6071,7 +6072,8 @@  package body Checks is
 
       --  An annoying special case. If this is an out parameter of a scalar
       --  type, then the value is not going to be accessed, therefore it is
-      --  inappropriate to do any validity check at the call site.
+      --  inappropriate to do any validity check at the call site. Likewise
+      --  if the parameter is passed by reference.
 
       else
          --  Only need to worry about scalar types
@@ -6097,25 +6099,20 @@  package body Checks is
                   P := Parent (N);
                end if;
 
-               --  Only need to worry if we are argument of a procedure call
-               --  since functions don't have out parameters. If this is an
-               --  indirect or dispatching call, get signature from the
-               --  subprogram type.
+               --  If this is an indirect or dispatching call, get signature
+               --  from the subprogram type.
 
-               if Nkind (P) = N_Procedure_Call_Statement then
+               if Nkind_In (P, N_Entry_Call_Statement,
+                               N_Function_Call,
+                               N_Procedure_Call_Statement)
+               then
+                  E := Get_Called_Entity (P);
                   L := Parameter_Associations (P);
 
-                  if Is_Entity_Name (Name (P)) then
-                     E := Entity (Name (P));
-                  else
-                     pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference);
-                     E := Etype (Name (P));
-                  end if;
-
                   --  Only need to worry if there are indeed actuals, and if
-                  --  this could be a procedure call, otherwise we cannot get a
-                  --  match (either we are not an argument, or the mode of the
-                  --  formal is not OUT). This test also filters out the
+                  --  this could be a subprogram call, otherwise we cannot get
+                  --  a match (either we are not an argument, or the mode of
+                  --  the formal is not OUT). This test also filters out the
                   --  generic case.
 
                   if Is_Non_Empty_List (L) and then Is_Subprogram (E) then
@@ -6126,7 +6123,10 @@  package body Checks is
                      F := First_Formal (E);
                      A := First (L);
                      while Present (F) loop
-                        if Ekind (F) = E_Out_Parameter and then A = N then
+                        if A = N
+                          and then (Ekind (F) = E_Out_Parameter
+                                     or else Mechanism (F) = By_Reference)
+                        then
                            return;
                         end if;
 

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/valid4.adb
@@ -0,0 +1,13 @@ 
+--  { dg-do run }
+--  { dg-options "-gnatVa" }
+
+with Valid4_Pkg; use Valid4_Pkg;
+
+procedure Valid4 is
+begin
+   Proc (Global);
+
+   if Global then
+      raise Program_Error;
+   end if;
+end Valid4;

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/valid4_pkg.adb
@@ -0,0 +1,19 @@ 
+package body Valid4_Pkg is
+   procedure Inner_Proc (B : in out Boolean);
+   pragma Export_Procedure
+     (Inner_Proc,
+      External        => "Inner_Proc",
+      Parameter_Types => (Boolean),
+      Mechanism       => Reference);
+
+   procedure Inner_Proc (B : in out Boolean) is
+   begin
+      B := True;
+      Global := False;
+   end Inner_Proc;
+
+   procedure Proc (B : in out Boolean) is
+   begin
+      Inner_Proc (B);
+   end Proc;
+end Valid4_Pkg;

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/valid4_pkg.ads
@@ -0,0 +1,10 @@ 
+package Valid4_Pkg is
+   Global : Boolean := False;
+
+   procedure Proc (B : in out Boolean);
+   pragma Export_Procedure
+     (Proc,
+      External        => "Proc",
+      Parameter_Types => (Boolean),
+      Mechanism       => Reference);
+end Valid4_Pkg;