This implements a new check name Predicate_Check that can be used in
Suppress and Unsuppress pragmas. This allows predicate checks to be
turned on and off for specific sections of code (unlike the effect
of Assertion_Policy which is to enable or disable predicates at the
point where they are defined).
The following compiled with -gnata prints
OK 1
OK 2
1. pragma Ada_2012;
2. with Text_IO; use Text_IO;
3. procedure Pcheck is
4. pragma Assertion_Policy (Predicate => Check);
5. type R is new Integer with
6. Dynamic_Predicate => R in 1 .. 10;
7. R1 : R;
8.
9. begin
10. declare
11. pragma Suppress (Predicate_Check);
12. begin
13. R1 := 11;
14. Put_Line ("OK 1");
15.
16. declare
17. pragma Unsuppress (Predicate_Check);
18. begin
19. R1 := 11;
20. Put_Line ("Not OK 1");
21. exception
22. when others =>
23. Put_Line ("OK 2");
24. end;
25. exception
26. when others =>
27. Put_Line ("Not OK 2");
28. end;
29. end Pcheck;
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-04-24 Robert Dewar <de...@adacore.com>
* checks.ads, checks.adb (Predicate_Checks_Suppressed): New function.
* exp_util.ads, exp_util.adb (Make_Predicate_Check): Check setting of
Predicate_Check.
* snames.ads-tmpl (Name_Predicate_Check): New check name.
* types.ads (Predicate_Check): New definition.
* gnat_rm.texi: Add documentation for Predicate_Check.
Index: checks.adb
===================================================================
--- checks.adb (revision 198221)
+++ checks.adb (working copy)
@@ -7750,6 +7750,19 @@
end if;
end Overflow_Checks_Suppressed;
+ ---------------------------------
+ -- Predicate_Checks_Suppressed --
+ ---------------------------------
+
+ function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean is
+ begin
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Predicate_Check);
+ else
+ return Scope_Suppress.Suppress (Predicate_Check);
+ end if;
+ end Predicate_Checks_Suppressed;
+
-----------------------------
-- Range_Checks_Suppressed --
-----------------------------
Index: checks.ads
===================================================================
--- checks.ads (revision 198221)
+++ checks.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -56,6 +56,7 @@
function Index_Checks_Suppressed (E : Entity_Id) return Boolean;
function Length_Checks_Suppressed (E : Entity_Id) return Boolean;
function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean;
function Range_Checks_Suppressed (E : Entity_Id) return Boolean;
function Storage_Checks_Suppressed (E : Entity_Id) return Boolean;
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 198221)
+++ exp_util.adb (working copy)
@@ -46,7 +46,6 @@
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
@@ -5472,18 +5471,11 @@
begin
pragma Assert
(Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
-
- if Check_Kind (Name_Invariant) = Name_Check then
- return
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
- Parameter_Associations => New_List (Relocate_Node (Expr)));
-
- else
- return
- Make_Null_Statement (Loc);
- end if;
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
end Make_Invariant_Call;
------------------------
@@ -5605,6 +5597,14 @@
Nam : Name_Id;
begin
+ -- If predicate checks are suppressed, then return a null statement.
+ -- For this call, we check only the scope setting. If the caller wants
+ -- to check a specific entity's setting, they must do it manually.
+
+ if Predicate_Checks_Suppressed (Empty) then
+ return Make_Null_Statement (Loc);
+ end if;
+
-- Compute proper name to use, we need to get this right so that the
-- right set of check policies apply to the Check pragma we are making.
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 198221)
+++ exp_util.ads (working copy)
@@ -665,8 +665,9 @@
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id;
-- Typ is a type with Predicate_Function set. This routine builds a Check
- -- pragma whose first argument is Predicate, and the second argument is a
- -- call to the this predicate function with Expr as the argument.
+ -- pragma whose first argument is Predicate, and the second argument is
+ -- a call to the predicate function of Typ with Expr as the argument. If
+ -- Predicate_Check is suppressed then a null statement is returned instead.
function Make_Subtype_From_Expr
(E : Node_Id;
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 198221)
+++ gnat_rm.texi (working copy)
@@ -5628,12 +5628,38 @@
@noindent
This is a standard pragma, and supports all the check names required in
-the RM. It is included here because GNAT recognizes one additional check
-name: @code{Alignment_Check} which can be used to suppress alignment checks
+the RM. It is included here because GNAT recognizes some additional check
+names that are implementation defined (as permitted by the RM):
+
+@itemize @bullet
+
+@item
+@code{Alignment_Check} can be used to suppress alignment checks
on addresses used in address clauses. Such checks can also be suppressed
by suppressing range checks, but the specific use of @code{Alignment_Check}
allows suppression of alignment checks without suppressing other range checks.
+@item
+@code{Predicate_Check} can be used to control whether predicate checks are
+active. It is applicable only to predicates for which the policy is
+@code{Check}. Unlike @code{Assertion_Policy}, which determines if a given
+predicate is ignored or checked for the whole program, the use of
+@code{Suppress} and @code{Unsuppress} with this check name allows a given
+predicate to be turned on and off at specific points in the program.
+
+@item
+@code{Validity_Check} can be used specifically to control validity checks.
+If @code{Suppress} is used to suppress validity checks, then no validity
+checks are performed, including those specified by the appropriate compiler
+switch or the @code{Validity_Checks} pragma.
+
+@item
+Additional check names previously introduced by use of the @code{Check_Name}
+pragma are also allowed.
+
+@end itemize
+
+@noindent
Note that pragma Suppress gives the compiler permission to omit
checks, but does not require the compiler to omit checks. The compiler
will generate checks if they are essentially free, even when they are
@@ -6182,6 +6208,10 @@
This pragma is standard in Ada 2005. It is available in all earlier versions
of Ada as an implementation-defined pragma.
+Note that in addition to the checks defined in the Ada RM, GNAT recogizes
+a number of implementation-defined check names. See description of pragma
+@code{Suppress} for full details.
+
@node Pragma Use_VADS_Size
@unnumberedsec Pragma Use_VADS_Size
@cindex @code{Size}, VADS compatibility
@@ -10430,6 +10460,12 @@
address clause values for proper alignment (that is, the address supplied
must be consistent with the alignment of the type).
+The implementation defined check name Predicate_Check controls whether
+predicate checks are generated.
+
+The implementation defined check name Validity_Check controls whether
+validity checks are generated.
+
In addition, a user program can add implementation-defined check names
by means of the pragma Check_Name.
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 198221)
+++ snames.ads-tmpl (working copy)
@@ -1082,6 +1082,7 @@
Name_Index_Check : constant Name_Id := N + $;
Name_Length_Check : constant Name_Id := N + $;
Name_Overflow_Check : constant Name_Id := N + $;
+ Name_Predicate_Check : constant Name_Id := N + $; -- GNAT
Name_Range_Check : constant Name_Id := N + $;
Name_Storage_Check : constant Name_Id := N + $;
Name_Tag_Check : constant Name_Id := N + $;
Index: types.ads
===================================================================
--- types.ads (revision 198221)
+++ types.ads (working copy)
@@ -666,15 +666,16 @@
Index_Check : constant := 8;
Length_Check : constant := 9;
Overflow_Check : constant := 10;
- Range_Check : constant := 11;
- Storage_Check : constant := 12;
- Tag_Check : constant := 13;
- Validity_Check : constant := 14;
+ Predicate_Check : constant := 11;
+ Range_Check : constant := 12;
+ Storage_Check : constant := 13;
+ Tag_Check : constant := 14;
+ Validity_Check : constant := 15;
-- Values used to represent individual predefined checks (including the
-- setting of Atomic_Synchronization, which is implemented internally using
- -- a "check" whose name is Atomic_Synchronization.
+ -- a "check" whose name is Atomic_Synchronization).
- All_Checks : constant := 15;
+ All_Checks : constant := 16;
-- Value used to represent All_Checks value
subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks;
