exp_prag.adb (Expand_Pragma_Check): Ignore pragma if Is_Ignored set.

2013-09-10  Robert Dewar  <dewar@adacore.com>

	* exp_prag.adb (Expand_Pragma_Check): Ignore pragma if Is_Ignored set.
	* sem_ch13.adb (Make_Aitem_Pragma): Set Is_Checked if needed.
	* sem_prag.adb (Check_Kind): Moved from spec (Analyze_Pragma):
	Make sure Is_Ignored/Is_Checked are set right (Analyze_Pragma,
	case Check): Ditto (Check_Applicable_Policy): Handle
	Statement_Assertion case Throughout, set and check the Is_Checked
	flag as appropriate.
	* sem_prag.ads (Check_Kind): Moved to body.
	* sinfo.ads, sinfo.adb (Is_Checked): New flag.

From-SVN: r202457

7 files changed, 159 insertions, 58 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 21dadb2..bfb9586 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,17 @@
 2013-09-10  Robert Dewar  <dewar@adacore.com>
 
+	* exp_prag.adb (Expand_Pragma_Check): Ignore pragma if Is_Ignored set.
+	* sem_ch13.adb (Make_Aitem_Pragma): Set Is_Checked if needed.
+	* sem_prag.adb (Check_Kind): Moved from spec (Analyze_Pragma):
+	Make sure Is_Ignored/Is_Checked are set right (Analyze_Pragma,
+	case Check): Ditto (Check_Applicable_Policy): Handle
+	Statement_Assertion case Throughout, set and check the Is_Checked
+	flag as appropriate.
+	* sem_prag.ads (Check_Kind): Moved to body.
+	* sinfo.ads, sinfo.adb (Is_Checked): New flag.
+
+2013-09-10  Robert Dewar  <dewar@adacore.com>
+
 	* aspects.ads (Delay_Type): New type (Aspect_Delay): New table.
 	* einfo.adb (Has_Delayed_Rep_Aspects): New flag
 	(May_Inherit_Delayed_Rep_Aspects): New flag (Rep_Clause): Removed
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index fba371e..eeafa72 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -287,10 +287,13 @@ package body Exp_Prag is
       Msg  : Node_Id;
 
    begin
-      --  We already know that this check is enabled, because otherwise the
-      --  semantic pass dealt with rewriting the assertion (see Sem_Prag)
+      --  Nothing to do if pragma is ignored
 
-      --  Since this check is enabled, we rewrite the pragma into a
+      if Is_Ignored (N) then
+         return;
+      end if;
+
+      --  Since this check is active, we rewrite the pragma into a
       --  corresponding if statement, and then analyze the statement
 
       --  The normal case expansion transforms:
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 03d635f..6738a5b 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1377,6 +1377,8 @@ package body Sem_Ch13 is
 
                if Is_Ignored (Aspect) then
                   Set_Is_Ignored (Aitem);
+               elsif Is_Checked (Aspect) then
+                  Set_Is_Checked (Aspect);
                end if;
 
                Set_Corresponding_Aspect (Aitem, Aspect);
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index cb3477b..f9dfab7 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -186,6 +186,25 @@ package body Sem_Prag is
    --  whether a particular item appears in a mixed list of nodes and entities.
    --  It is assumed that all nodes in the list have entities.
 
+   function Check_Kind (Nam : Name_Id) return Name_Id;
+   --  This function is used in connection with pragmas Assert, Check,
+   --  and assertion aspects and pragmas, to determine if Check pragmas
+   --  (or corresponding assertion aspects or pragmas) are currently active
+   --  as determined by the presence of -gnata on the command line (which
+   --  sets the default), and the appearance of pragmas Check_Policy and
+   --  Assertion_Policy as configuration pragmas either in a configuration
+   --  pragma file, or at the start of the current unit, or locally given
+   --  Check_Policy and Assertion_Policy pragmas that are currently active.
+   --
+   --  The value returned is one of the names Check, Ignore, Disable (On
+   --  returns Check, and Off returns Ignore).
+   --
+   --  Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
+   --  and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
+   --  Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
+   --  _Post, _Invariant, or _Type_Invariant, which are special names used
+   --  in identifiers to represent these attribute references.
+
    procedure Collect_Subprogram_Inputs_Outputs
      (Subp_Id      : Entity_Id;
       Subp_Inputs  : in out Elist_Id;
@@ -3502,7 +3521,7 @@ package body Sem_Prag is
          --  For a pragma PPC in the extended main source unit, record enabled
          --  status in SCO.
 
-         if not Is_Ignored (N) and then not Split_PPC (N) then
+         if Is_Checked (N) and then not Split_PPC (N) then
             Set_SCO_Pragma_Enabled (Loc);
          end if;
 
@@ -8171,11 +8190,27 @@ package body Sem_Prag is
       Prag_Id := Get_Pragma_Id (Pname);
       Pname := Original_Name (N);
 
-      --  Check applicable policy. We skip this for a pragma that came from
-      --  an aspect, since we already dealt with the Disable case, and we set
-      --  the Is_Ignored flag at the time the aspect was analyzed.
+      --  Check applicable policy. We skip this if Is_Checked or Is_Ignored
+      --  is already set, indicating that we have already checked the policy
+      --  at the right point. This happens for example in the case of a pragma
+      --  that is derived from an Aspect.
+
+      if Is_Ignored (N) or else Is_Checked (N) then
+         null;
+
+      --  For a pragma that is a rewriting of another pragma, copy the
+      --  Is_Checked/Is_Ignored status from the rewritten pragma.
+
+      elsif Is_Rewrite_Substitution (N)
+        and then Nkind (Original_Node (N)) = N_Pragma
+        and then Original_Node (N) /= N
+      then
+         Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
+         Set_Is_Checked (N, Is_Checked (Original_Node (N)));
+
+      --  Otherwise query the applicable policy at this point
 
-      if not From_Aspect_Specification (N) then
+      else
          Check_Applicable_Policy (N);
 
          --  If pragma is disabled, rewrite as NULL and skip analysis
@@ -8886,6 +8921,8 @@ package body Sem_Prag is
                Append_To (Newa, New_Copy_Tree (Arg2));
             end if;
 
+            --  Rewrite as Check pragma
+
             Rewrite (N,
               Make_Pragma (Loc,
                 Chars                        => Name_Check,
@@ -9497,9 +9534,6 @@ package body Sem_Prag is
             Cname : Name_Id;
             Str   : Node_Id;
 
-            Check_On : Boolean;
-            --  Set True if category of assertions referenced by Name enabled
-
          begin
             GNAT_Pragma;
             Check_At_Least_N_Arguments (2);
@@ -9533,24 +9567,33 @@ package body Sem_Prag is
                   null;
             end case;
 
-            --  Set Check_On to indicate check status
+            --  Check applicable policy. We skip this if Checked/Ignored status
+            --  is already set (e.g. in the casse of a pragma from an aspect).
 
-            --  If this comes from an aspect, we have already taken care of
-            --  the policy active when the aspect was analyzed, and Is_Ignored
-            --  is set appropriately already.
+            if Is_Checked (N) or else Is_Ignored (N) then
+               null;
 
-            if From_Aspect_Specification (N) then
-               Check_On := not Is_Ignored (N);
+            --  For a non-source pragma that is a rewriting of another pragma,
+            --  copy the Is_Checked/Ignored status from the rewritten pragma.
 
-            --  Otherwise check the status right now
+            elsif Is_Rewrite_Substitution (N)
+              and then Nkind (Original_Node (N)) = N_Pragma
+              and then Original_Node (N) /= N
+            then
+               Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
+               Set_Is_Checked (N, Is_Checked (Original_Node (N)));
+
+            --  Otherwise query the applicable policy at this point
 
             else
                case Check_Kind (Cname) is
                   when Name_Ignore =>
-                     Check_On := False;
+                     Set_Is_Ignored (N, True);
+                     Set_Is_Checked (N, False);
 
                   when Name_Check =>
-                     Check_On := True;
+                     Set_Is_Ignored (N, False);
+                     Set_Is_Checked (N, True);
 
                   --  For disable, rewrite pragma as null statement and skip
                   --  rest of the analysis of the pragma.
@@ -9585,7 +9628,7 @@ package body Sem_Prag is
 
                when others =>
 
-                  if Check_On and then not Split_PPC (N) then
+                  if Is_Checked (N) and then not Split_PPC (N) then
 
                      --  Mark pragma/aspect SCO as enabled
 
@@ -9602,7 +9645,7 @@ package body Sem_Prag is
                --  we do want to analyze (to get proper references).
                --  The Preanalyze_And_Resolve routine does just what we want
 
-               if not Check_On then
+               if Is_Ignored (N) then
                   Preanalyze_And_Resolve (Str, Standard_String);
 
                   --  Otherwise we need a proper analysis and expansion
@@ -9625,11 +9668,11 @@ package body Sem_Prag is
             --       null;
             --    end if;
 
-            --  The reason we do this rewriting during semantic analysis
-            --  rather than as part of normal expansion is that we cannot
-            --  analyze and expand the code for the boolean expression
-            --  directly, or it may cause insertion of actions that would
-            --  escape the attempt to suppress the check code.
+            --  The reason we do this rewriting during semantic analysis rather
+            --  than as part of normal expansion is that we cannot analyze and
+            --  expand the code for the boolean expression directly, or it may
+            --  cause insertion of actions that would escape the attempt to
+            --  suppress the check code.
 
             --  Note that the Sloc for the if statement corresponds to the
             --  argument condition, not the pragma itself. The reason for
@@ -9637,7 +9680,7 @@ package body Sem_Prag is
             --  False at compile time, and we do not want to delete this
             --  warning when we delete the if statement.
 
-            if Expander_Active and not Check_On then
+            if Expander_Active and Is_Ignored (N) then
                Eloc := Sloc (Expr);
 
                Rewrite (N,
@@ -15047,11 +15090,9 @@ package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_Check);
             Check_Precondition_Postcondition (In_Body);
 
-            --  If in spec, nothing more to do. If in body, then we convert the
-            --  pragma to an equivalent pragam Check. Note we do this whether
-            --  or not precondition checks are enabled. That works fine since
-            --  pragma Check will do this check, and will also analyze the
-            --  condition itself in the proper context.
+            --  If in spec, nothing more to do. If in body, then we convert
+            --  the pragma to an equivalent pragma Check. That works fine since
+            --  pragma Check will analyze the condition in the proper context.
 
             --  The form of the pragma Check is either:
 
@@ -15064,20 +15105,25 @@ package body Sem_Prag is
             --  pragmas are checked.
 
             if In_Body then
+
+               --  Rewrite as Check pragma
+
                Rewrite (N,
                  Make_Pragma (Loc,
                    Chars                        => Name_Check,
                    Pragma_Argument_Associations => New_List (
                      Make_Pragma_Argument_Association (Loc,
-                       Expression => Make_Identifier (Loc, Pname)),
+                     Expression => Make_Identifier (Loc, Pname)),
 
                      Make_Pragma_Argument_Association (Sloc (Arg1),
-                       Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
+                       Expression =>
+                         Relocate_Node (Get_Pragma_Arg (Arg1))))));
 
                if Arg_Count = 2 then
                   Append_To (Pragma_Argument_Associations (N),
                     Make_Pragma_Argument_Association (Sloc (Arg2),
-                      Expression => Relocate_Node (Get_Pragma_Arg (Arg2))));
+                      Expression =>
+                        Relocate_Node (Get_Pragma_Arg (Arg2))));
                end if;
 
                Analyze (N);
@@ -18298,17 +18344,33 @@ package body Sem_Prag is
             Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
 
          begin
-            if Ename = Pnm or else Pnm = Name_Assertion then
+            if Ename = Pnm
+              or else Pnm = Name_Assertion
+              or else (Pnm = Name_Statement_Assertions
+                        and then (Ename = Name_Assert         or else
+                                  Ename = Name_Assert_And_Cut or else
+                                  Ename = Name_Assume         or else
+                                  Ename = Name_Loop_Invariant))
+            then
                Policy := Chars (Get_Pragma_Arg (Last (PPA)));
 
                case Policy is
                   when Name_Off | Name_Ignore =>
                      Set_Is_Ignored (N, True);
+                     Set_Is_Checked (N, False);
+
+                  when Name_On | Name_Check =>
+                     Set_Is_Checked (N, True);
+                     Set_Is_Ignored (N, False);
 
                   when Name_Disable =>
                      Set_Is_Ignored  (N, True);
+                     Set_Is_Checked  (N, False);
                      Set_Is_Disabled (N, True);
 
+                  --  That should be exhaustive, the null here is a defence
+                  --  against a malformed tree from previous errors.
+
                   when others =>
                      null;
                end case;
@@ -18325,8 +18387,12 @@ package body Sem_Prag is
       --  compatibility with the RM for the cases of assertion, invariant,
       --  precondition, predicate, and postcondition.
 
-      if not Assertions_Enabled then
-         Set_Is_Ignored (N);
+      if Assertions_Enabled then
+         Set_Is_Checked (N, True);
+         Set_Is_Ignored (N, False);
+      else
+         Set_Is_Checked (N, False);
+         Set_Is_Ignored (N, True);
       end if;
    end Check_Applicable_Policy;
 
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index fcbe988..7819931 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -63,25 +63,6 @@ package Sem_Prag is
    --  expressions in the pragma as "spec expressions" (see section in Sem
    --  "Handling of Default and Per-Object Expressions...").
 
-   function Check_Kind (Nam : Name_Id) return Name_Id;
-   --  This function is used in connection with pragmas Assert, Check,
-   --  and assertion aspects and pragmas, to determine if Check pragmas
-   --  (or corresponding assertion aspects or pragmas) are currently active
-   --  as determined by the presence of -gnata on the command line (which
-   --  sets the default), and the appearance of pragmas Check_Policy and
-   --  Assertion_Policy as configuration pragmas either in a configuration
-   --  pragma file, or at the start of the current unit, or locally given
-   --  Check_Policy and Assertion_Policy pragmas that are currently active.
-   --
-   --  The value returned is one of the names Check, Ignore, Disable (On
-   --  returns Check, and Off returns Ignore).
-   --
-   --  Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
-   --  and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
-   --  Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
-   --  _Post, _Invariant, or _Type_Invariant, which are special names used
-   --  in identifiers to represent these attribute references.
-
    procedure Check_Applicable_Policy (N : Node_Id);
    --  N is either an N_Aspect or an N_Pragma node. There are two cases. If
    --  the name of the aspect or pragma is not one of those recognized as
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index c8eab8a..6cb18c1 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -1732,6 +1732,15 @@ package body Sinfo is
       return Flag16 (N);
    end Is_Boolean_Aspect;
 
+   function Is_Checked
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aspect_Specification
+        or else NT (N).Nkind = N_Pragma);
+      return Flag11 (N);
+   end Is_Checked;
+
    function Is_Component_Left_Opnd
       (N : Node_Id) return Boolean is
    begin
@@ -4840,6 +4849,15 @@ package body Sinfo is
       Set_Flag16 (N, Val);
    end Set_Is_Boolean_Aspect;
 
+   procedure Set_Is_Checked
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aspect_Specification
+        or else NT (N).Nkind = N_Pragma);
+      Set_Flag11 (N, Val);
+   end Set_Is_Checked;
+
    procedure Set_Is_Component_Left_Opnd
       (N : Node_Id; Val : Boolean := True) is
    begin
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 48b750b..906077b 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1269,6 +1269,15 @@ package Sinfo is
    --    Present in N_Aspect_Specification node. Set if the aspect is for a
    --    boolean aspect (i.e. Aspect_Id is in Boolean_Aspect subtype).
 
+   --  Is_Checked (Flag11-Sem)
+   --    Present in N_Aspect_Specification and N_Pragma nodes. Set for an
+   --    assertion aspect or pragma, or check pragma for an assertion, that
+   --    is to be checked at run - time. If either Is_Checked or Is_Ignored
+   --    is set (they cannot both be set), then this means that the status of
+   --    the pragma has been checked at the appropriate point and should not
+   --    be further modified (in some cases these flags are copied when a
+   --    pragma is rewritten).
+
    --  Is_Component_Left_Opnd  (Flag13-Sem)
    --  Is_Component_Right_Opnd (Flag14-Sem)
    --    Present in concatenation nodes, to indicate that the corresponding
@@ -2116,6 +2125,7 @@ package Sinfo is
       --  Is_Delayed_Aspect (Flag14-Sem)
       --  Is_Disabled (Flag15-Sem)
       --  Is_Ignored (Flag9-Sem)
+      --  Is_Checked (Flag11-Sem)
       --  Import_Interface_Present (Flag16-Sem)
       --  Split_PPC (Flag17) set if corresponding aspect had Split_PPC set
 
@@ -6763,6 +6773,7 @@ package Sinfo is
       --  Next_Rep_Item (Node5-Sem)
       --  Split_PPC (Flag17) Set if split pre/post attribute
       --  Is_Boolean_Aspect (Flag16-Sem)
+      --  Is_Checked (Flag11-Sem)
       --  Is_Delayed_Aspect (Flag14-Sem)
       --  Is_Disabled (Flag15-Sem)
       --  Is_Ignored (Flag9-Sem)
@@ -8725,6 +8736,9 @@ package Sinfo is
    function Is_Boolean_Aspect
      (N : Node_Id) return Boolean;    -- Flag16
 
+   function Is_Checked
+     (N : Node_Id) return Boolean;    -- Flag11
+
    function Is_Component_Left_Opnd
      (N : Node_Id) return Boolean;    -- Flag13
 
@@ -9715,6 +9729,9 @@ package Sinfo is
    procedure Set_Is_Boolean_Aspect
      (N : Node_Id; Val : Boolean := True);    -- Flag16
 
+   procedure Set_Is_Checked
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
    procedure Set_Is_Component_Left_Opnd
      (N : Node_Id; Val : Boolean := True);    -- Flag13
 
@@ -12100,6 +12117,7 @@ package Sinfo is
    pragma Inline (Is_Accessibility_Actual);
    pragma Inline (Is_Asynchronous_Call_Block);
    pragma Inline (Is_Boolean_Aspect);
+   pragma Inline (Is_Checked);
    pragma Inline (Is_Component_Left_Opnd);
    pragma Inline (Is_Component_Right_Opnd);
    pragma Inline (Is_Controlling_Actual);
@@ -12425,6 +12443,7 @@ package Sinfo is
    pragma Inline (Set_Is_Accessibility_Actual);
    pragma Inline (Set_Is_Asynchronous_Call_Block);
    pragma Inline (Set_Is_Boolean_Aspect);
+   pragma Inline (Set_Is_Checked);
    pragma Inline (Set_Is_Component_Left_Opnd);
    pragma Inline (Set_Is_Component_Right_Opnd);
    pragma Inline (Set_Is_Controlling_Actual);