Previous check-in for this ticket was incomplete. It did not properly
cover invariants inherited from one type to another.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-05 Bob Duff <d...@adacore.com>
gcc/ada/
* einfo.adb, einfo.ads, exp_util.adb: Remove Invariants_Ignored
flag.
* sem_prag.adb (Invariant): Instead of setting a flag to be
checked elsewhere, remove the pragma as soon as it is analyzed
and checked for legality.--- 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,12 +2077,6 @@ 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));
@@ -5284,12 +5278,6 @@ 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));
@@ -9797,7 +9785,6 @@ 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
@@ -2269,11 +2269,6 @@ 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
@@ -7289,7 +7284,6 @@ 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;
@@ -7993,7 +7987,6 @@ 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);
@@ -8826,7 +8819,6 @@ 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);
@@ -9364,7 +9356,6 @@ 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
@@ -9331,16 +9331,10 @@ package body Exp_Util is
Proc_Id := Invariant_Procedure (Typ);
pragma Assert (Present (Proc_Id));
- -- 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;
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Proc_Id, Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
end Make_Invariant_Call;
------------------------
--- gcc/ada/sem_prag.adb
+++ gcc/ada/sem_prag.adb
@@ -18316,6 +18316,20 @@ package body Sem_Prag is
return;
end if;
+ -- If invariants should be ignored, delete the pragma and then
+ -- return. We do this here, after checking for errors, and before
+ -- generating anything that has a run-time effect.
+
+ if Present (Check_Policy_List)
+ and then
+ (Policy_In_Effect (Name_Invariant) = Name_Ignore
+ and then
+ Policy_In_Effect (Name_Type_Invariant) = Name_Ignore)
+ then
+ Rewrite (N, Make_Null_Statement (Loc));
+ return;
+ end if;
+
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
@@ -18326,15 +18340,6 @@ 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.
