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 <d...@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.--- 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.
