From 00420f7430267c2df25b71edcb401e4df443ac01 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Thu, 12 Jan 2017 13:55:59 +0000 Subject: [PATCH] sem_prag.adb (Analyze_Pragma): Add appropriate calls to Resolve_Suppressible in the pragma Assertion_Policy case. 2017-01-12 Justin Squirek * sem_prag.adb (Analyze_Pragma): Add appropriate calls to Resolve_Suppressible in the pragma Assertion_Policy case. (Resolve_Suppressible): Created this function to factor out common code used to resolve Suppress to either Ignore or Check * snames.ads-tmpl: Add name for Suppressible. From-SVN: r244362 --- gcc/ada/ChangeLog | 8 +++++++ gcc/ada/sem_prag.adb | 46 ++++++++++++++++++++++++++++++++++++----- gcc/ada/snames.ads-tmpl | 1 + 3 files changed, 50 insertions(+), 5 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ce59afba66b..a7d230b094c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,11 @@ +2017-01-12 Justin Squirek + + * sem_prag.adb (Analyze_Pragma): Add appropriate calls to + Resolve_Suppressible in the pragma Assertion_Policy case. + (Resolve_Suppressible): Created this function to factor out + common code used to resolve Suppress to either Ignore or Check + * snames.ads-tmpl: Add name for Suppressible. + 2017-01-12 Gary Dismukes * exp_ch9.adb, s-secsta.adb, snames.ads-tmpl, exp_ch3.adb: Minor diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 031e00cbe02..58dd3e8079a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -11812,7 +11812,7 @@ package body Sem_Prag is -- identically named aspects and pragmas, depending on the specified -- policy identifier: - -- POLICY_IDENTIFIER ::= Check | Disable | Ignore + -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible -- Note: Check and Ignore are language-defined. Disable is a GNAT -- implementation-defined addition that results in totally ignoring @@ -11828,6 +11828,38 @@ package body Sem_Prag is -- processing is required here. when Pragma_Assertion_Policy => Assertion_Policy : declare + + procedure Resolve_Suppressible (Policy : Node_Id); + -- Converts the assertion policy 'Suppressible' to either Check or + -- ignore based on whether checks are suppressed via -gnatp or ??? + + -------------------------- + -- Resolve_Suppressible -- + -------------------------- + + procedure Resolve_Suppressible (Policy : Node_Id) is + Nam : Name_Id; + ARG : constant Node_Id := Get_Pragma_Arg (Policy); + + begin + if Chars (Expression (Policy)) = Name_Suppressible then + + -- Rewrite the policy argument node to either Ignore or + -- Check. This is done because the argument is referenced + -- directly later during analysis. + + if Suppress_Checks then + Nam := Name_Ignore; + else + Nam := Name_Check; + end if; + + Rewrite (ARG, Make_Identifier (Sloc (ARG), Nam)); + end if; + end Resolve_Suppressible; + + -- Local variables + Arg : Node_Id; Kind : Name_Id; LocP : Source_Ptr; @@ -11856,8 +11888,10 @@ package body Sem_Prag is and then (Nkind (Arg1) /= N_Pragma_Argument_Association or else Chars (Arg1) = No_Name) then - Check_Arg_Is_One_Of - (Arg1, Name_Check, Name_Disable, Name_Ignore); + Check_Arg_Is_One_Of (Arg1, + Name_Check, Name_Disable, Name_Ignore, Name_Suppressible); + + Resolve_Suppressible (Arg1); -- Treat one argument Assertion_Policy as equivalent to: @@ -11911,8 +11945,10 @@ package body Sem_Prag is ("invalid assertion kind for pragma%", Arg); end if; - Check_Arg_Is_One_Of - (Arg, Name_Check, Name_Disable, Name_Ignore); + Check_Arg_Is_One_Of (Arg, + Name_Check, Name_Disable, Name_Ignore, Name_Suppressible); + + Resolve_Suppressible (Arg); if Kind = Name_Ghost then diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index ebb7f680b76..5941beb3317 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -818,6 +818,7 @@ package Snames is Name_Strict : constant Name_Id := N + $; Name_Subunit_File_Name : constant Name_Id := N + $; Name_Suppressed : constant Name_Id := N + $; + Name_Suppressible : constant Name_Id := N + $; Name_Synchronous : constant Name_Id := N + $; Name_Task_Stack_Size_Default : constant Name_Id := N + $; Name_Task_Type : constant Name_Id := N + $; -- 2.30.2