From 08f66419ef908d199ec55f24d9b64cc3287a5c3c Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Thu, 10 Oct 2019 15:23:33 +0000 Subject: [PATCH] [Ada] Assertion_Policy (Ignore) ignores invariants 2019-10-10 Bob Duff 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 --- gcc/ada/ChangeLog | 8 +++++--- gcc/ada/einfo.adb | 15 ++++++++++++++- gcc/ada/einfo.ads | 13 +++++++++++-- gcc/ada/exp_util.adb | 14 ++++++++++---- gcc/ada/sem_prag.adb | 9 +++++++++ 5 files changed, 49 insertions(+), 10 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f4484cb309a..082fcf463a2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,4 +1,6 @@ -2019-10-10 Arnaud Charlet +2019-10-10 Bob Duff - * 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 dcbeac5780c..98b508f6590 100644 --- 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 3e968a29bd8..536663142cc 100644 --- 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 6306320c0cd..36c900b2a28 100644 --- 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 76dd7116301..f9ce1d9ae25 100644 --- 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. -- 2.30.2