[Ada] Assertion_Policy (Ignore) ignores invariants

2019-10-10  Bob Duff  <duff@adacore.com>

gcc/ada/

	* einfo.ads, einfo.adb (Invariants_Ignored): New flag on types.
	This leaves just one unused flag.
	* sem_prag.adb (Invariant): Set the flag if appropriate.
	* exp_util.adb (Make_Invariant_Call): Check the flag.

From-SVN: r276818

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index f4484cb..082fcf4 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,4 +1,6 @@
-2019-10-10  Arnaud Charlet  <charlet@adacore.com>
+2019-10-10  Bob Duff  <duff@adacore.com>
 
-       * gnat1drv.adb (Gnat1drv): Skip code generation when handling an
-       incomplete unit with -gnatceg.
\ No newline at end of file
+       * einfo.ads, einfo.adb (Invariants_Ignored): New flag on types.
+       This leaves just one unused flag.
+       * sem_prag.adb (Invariant): Set the flag if appropriate.
+       * exp_util.adb (Make_Invariant_Call): Check the flag.
\ No newline at end of file

diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index dcbeac5..98b508f 100644 (file)
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -629,8 +629,8 @@ package body Einfo is
    --    Is_Activation_Record            Flag305
    --    Needs_Activation_Record         Flag306
    --    Is_Loop_Parameter               Flag307
+   --    Invariants_Ignored              Flag308
 
-   --    (unused)                        Flag308
    --    (unused)                        Flag309
 
    --  Note: Flag310-317 are defined in atree.ads/adb, but not yet in atree.h
@@ -2077,6 +2077,12 @@ package body Einfo is
       return Node21 (Id);
    end Interface_Name;
 
+   function Invariants_Ignored (Id : E) return B is
+   begin
+      pragma Assert (Is_Type (Id));
+      return Flag308 (Id);
+   end Invariants_Ignored;
+
    function Is_Abstract_Subprogram (Id : E) return B is
    begin
       pragma Assert (Is_Overloadable (Id));
@@ -5278,6 +5284,12 @@ package body Einfo is
       Set_Node21 (Id, V);
    end Set_Interface_Name;
 
+   procedure Set_Invariants_Ignored (Id : E; V : B := True) is
+   begin
+      pragma Assert (Is_Type (Id));
+      Set_Flag308 (Id, V);
+   end Set_Invariants_Ignored;
+
    procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True) is
    begin
       pragma Assert (Is_Overloadable (Id));
@@ -9785,6 +9797,7 @@ package body Einfo is
       W ("In_Package_Body",                 Flag48  (Id));
       W ("In_Private_Part",                 Flag45  (Id));
       W ("In_Use",                          Flag8   (Id));
+      W ("Invariants_Ignored",              Flag308 (Id));
       W ("Is_Abstract_Subprogram",          Flag19  (Id));
       W ("Is_Abstract_Type",                Flag146 (Id));
       W ("Is_Access_Constant",              Flag69  (Id));

diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 3e968a2..5366631 100644 (file)
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1739,7 +1739,7 @@ package Einfo is
 
 --    Has_Inherited_Invariants (Flag291) [base type only]
 --       Defined in all type entities. Set on private extensions and derived
---       types which inherit at least on class-wide invariant from a parent or
+--       types which inherit at least one class-wide invariant from a parent or
 --       an interface type. The flag is also set on the full view of a private
 --       extension for completeness.
 
@@ -1841,7 +1841,7 @@ package Einfo is
 --       when the type is subject to pragma Default_Initial_Condition.
 
 --    Has_Own_Invariants (Flag232) [base type only]
---       Defined in all type entities. Set on any type which defines at least
+--       Defined in all type entities. Set on any type that defines at least
 --       one invariant of its own. The flag is also set on the full view of a
 --       private type for completeness.
 
@@ -2259,6 +2259,11 @@ package Einfo is
 --       implemented by a tagged type that are not already implemented by the
 --       ancestors (Ada 2005: AI-251).
 
+--    Invariants_Ignored (Flag308)
+--       Defined on all types. Indicates whether the type declaration is in
+--       a context where Assertion_Policy is Ignore, in which case no checks
+--       (static or dynamic) must be generated for objects of the type.
+
 --    Invariant_Procedure (synthesized)
 --       Defined in types and subtypes. Set for private types and their full
 --       views if one or more [class-wide] invariants apply to the type, or
@@ -7272,6 +7277,7 @@ package Einfo is
    function Interface_Alias                     (Id : E) return E;
    function Interface_Name                      (Id : E) return N;
    function Interfaces                          (Id : E) return L;
+   function Invariants_Ignored                  (Id : E) return B;
    function Is_Abstract_Subprogram              (Id : E) return B;
    function Is_Abstract_Type                    (Id : E) return B;
    function Is_Access_Constant                  (Id : E) return B;
@@ -7973,6 +7979,7 @@ package Einfo is
    procedure Set_Interface_Alias                 (Id : E; V : E);
    procedure Set_Interface_Name                  (Id : E; V : N);
    procedure Set_Interfaces                      (Id : E; V : L);
+   procedure Set_Invariants_Ignored              (Id : E; V : B := True);
    procedure Set_Is_Abstract_Subprogram          (Id : E; V : B := True);
    procedure Set_Is_Abstract_Type                (Id : E; V : B := True);
    procedure Set_Is_Access_Constant              (Id : E; V : B := True);
@@ -8801,6 +8808,7 @@ package Einfo is
    pragma Inline (Interface_Alias);
    pragma Inline (Interface_Name);
    pragma Inline (Interfaces);
+   pragma Inline (Invariants_Ignored);
    pragma Inline (Is_Abstract_Subprogram);
    pragma Inline (Is_Abstract_Type);
    pragma Inline (Is_Access_Constant);
@@ -9338,6 +9346,7 @@ package Einfo is
    pragma Inline (Set_Interface_Alias);
    pragma Inline (Set_Interface_Name);
    pragma Inline (Set_Interfaces);
+   pragma Inline (Set_Invariants_Ignored);
    pragma Inline (Set_Is_Abstract_Subprogram);
    pragma Inline (Set_Is_Abstract_Type);
    pragma Inline (Set_Is_Access_Constant);

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 6306320..36c900b 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -9388,10 +9388,16 @@ package body Exp_Util is
       Proc_Id := Invariant_Procedure (Typ);
       pragma Assert (Present (Proc_Id));
 
-      return
-        Make_Procedure_Call_Statement (Loc,
-          Name                   => New_Occurrence_Of (Proc_Id, Loc),
-          Parameter_Associations => New_List (Relocate_Node (Expr)));
+      --  Ignore the invariant if that policy is in effect
+
+      if Invariants_Ignored (Typ) then
+         return Make_Null_Statement (Loc);
+      else
+         return
+           Make_Procedure_Call_Statement (Loc,
+             Name                   => New_Occurrence_Of (Proc_Id, Loc),
+             Parameter_Associations => New_List (Relocate_Node (Expr)));
+      end if;
    end Make_Invariant_Call;
 
    ------------------------

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 76dd711..f9ce1d9 100644 (file)
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -18816,6 +18816,15 @@ package body Sem_Prag is
 
             Set_Has_Own_Invariants (Typ);
 
+            --  Set the Invariants_Ignored flag if that policy is in effect
+
+            Set_Invariants_Ignored (Typ,
+              Present (Check_Policy_List)
+                and then
+                  (Policy_In_Effect (Name_Invariant) = Name_Ignore
+                     and then
+                   Policy_In_Effect (Name_Type_Invariant) = Name_Ignore));
+
             --  If the invariant is class-wide, then it can be inherited by
             --  derived or interface implementing types. The type is said to
             --  have "inheritable" invariants.