aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorBob Duff <duff@adacore.com>2019-10-10 15:23:33 +0000
committerPierre-Marie de Rodat <pmderodat@gcc.gnu.org>2019-10-10 15:23:33 +0000
commit08f66419ef908d199ec55f24d9b64cc3287a5c3c (patch)
tree10ee39e225039967caa8681796419e1f5bcfb49c /gcc/ada
parentd145e5628f3a72abb2991e2fe9f45af963500ee5 (diff)
downloadgcc-08f66419ef908d199ec55f24d9b64cc3287a5c3c.zip
gcc-08f66419ef908d199ec55f24d9b64cc3287a5c3c.tar.gz
gcc-08f66419ef908d199ec55f24d9b64cc3287a5c3c.tar.bz2
[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
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog8
-rw-r--r--gcc/ada/einfo.adb15
-rw-r--r--gcc/ada/einfo.ads13
-rw-r--r--gcc/ada/exp_util.adb14
-rw-r--r--gcc/ada/sem_prag.adb9
5 files changed, 49 insertions, 10 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index f4484cb..082fcf4 100644
--- 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
--- 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
--- 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
--- 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
--- 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.