[Ada] Assertion_Policy (Ignore) ignores invariants

Message ID 20191010152946.GA87538@adacore.com
State New
Headers show
Series
  • [Ada] Assertion_Policy (Ignore) ignores invariants
Related show

Commit Message

Pierre-Marie de Rodat Oct. 10, 2019, 3:29 p.m.
A pragma Assertion_Policy (Ignore) was ignored with respect to
invariants; invariants are checked even in the presence of this pragma.
This patch fixes that bug.

Running these commands:

  gcc -S -fverbose-asm -g ess-main.adb -gnata
  grep Invariant ess-main.s

On the following sources:

pragma Assertion_Policy (Ignore);

package Ess is
   type T is private;
   procedure P (X : T);
private

   type T is record
      A : Integer;
   end record with
      Invariant => T.A = 3;

end Ess;

pragma Assertion_Policy (Ignore);

package body Ess is
   procedure P (X : T) is
      Obj : T;
   begin
      Obj.A := 4;
   end P;
end Ess;

pragma Assertion_Policy (Ignore);

procedure Ess.Main (X : T) is
   Obj : T;
begin
   Obj.A := 4;
   P (Obj);
end Ess.Main;

Should execute silently.

Tested on x86_64-pc-linux-gnu, committed on trunk

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.

Patch

--- gcc/ada/einfo.adb
+++ 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));

--- gcc/ada/einfo.ads
+++ 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);

--- gcc/ada/exp_util.adb
+++ 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;
 
    ------------------------

--- gcc/ada/sem_prag.adb
+++ 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.