From: pmderodat Date: Tue, 11 Dec 2018 11:12:11 +0000 (+0000) Subject: [Ada] Volatility, validity checks, and System.Aux_DEC X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=becb611194705df0c131a3d94f6767499f8ef7ac;p=thirdparty%2Fgcc.git [Ada] Volatility, validity checks, and System.Aux_DEC 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. 2018-12-11 Hristian Kirtchev 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@267012 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d38e966d08b2..3dc73b358846 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2018-12-11 Hristian Kirtchev + + * 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. + 2018-12-11 Yannick Moy * sem_prag.adb (Analyze_Global_Item): Refine error message. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 8db6b0f84306..d115ce10e020 100644 --- a/gcc/ada/checks.adb +++ b/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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7a71ed1bc554..02337b805d73 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-12-11 Hristian Kirtchev + + * gnat.dg/valid4.adb, gnat.dg/valid4_pkg.adb, + gnat.dg/valid4_pkg.ads: New testcase. + 2018-12-11 Eric Botcazou * gnat.dg/packed_array.adb, gnat.dg/packed_array.ads, diff --git a/gcc/testsuite/gnat.dg/valid4.adb b/gcc/testsuite/gnat.dg/valid4.adb new file mode 100644 index 000000000000..b64c52697768 --- /dev/null +++ b/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; diff --git a/gcc/testsuite/gnat.dg/valid4_pkg.adb b/gcc/testsuite/gnat.dg/valid4_pkg.adb new file mode 100644 index 000000000000..cafb459e5946 --- /dev/null +++ b/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; diff --git a/gcc/testsuite/gnat.dg/valid4_pkg.ads b/gcc/testsuite/gnat.dg/valid4_pkg.ads new file mode 100644 index 000000000000..91c36d74d4f6 --- /dev/null +++ b/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;