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 <kirtc...@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.--- 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;
