From: Javier Miranda <mira...@adacore.com>
The compiler does not generate dynamic predicate checks when
they are enabled for one type declaration and ignored for
other type declarations defined in the same scope.
gcc/ada/
* sem_ch13.adb (Analyze_One_Aspect): Set the applicable policy
of a type declaration when its aspect Dynamic_Predicate is
analyzed.
* sem_prag.adb (Handle_Dynamic_Predicate_Check): New subprogram
that enables or ignores dynamic predicate checks depending on
whether dynamic checks are enabled in the context where the
associated type declaration is defined; used in the analysis
of pragma check. In addition, for pragma Predicate, do not
disable it when the aspect was internally build as part of
processing a dynamic predicate aspect.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch13.adb | 16 ++++++++
gcc/ada/sem_prag.adb | 98 +++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 112 insertions(+), 2 deletions(-)
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index f84ca2c75d7..34aef434501 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -3194,6 +3194,22 @@ package body Sem_Ch13 is
Set_Has_Static_Predicate_Aspect (E, False);
+ -- Query the applicable policy since it must rely on the
+ -- policy applicable in the context of the declaration of
+ -- entity E; it cannot be done when the built pragma is
+ -- analyzed because it will be analyzed when E is frozen,
+ -- and at that point the applicable policy may differ.
+ -- For example:
+
+ -- pragma Assertion_Policy (Dynamic_Predicate => Check);
+ -- type T is ... with Dynamic_Predicate => ...
+ -- pragma Assertion_Policy (Dynamic_Predicate => Ignore);
+ -- X : T; -- freezes T
+
+ Set_Predicates_Ignored (E,
+ Policy_In_Effect (Name_Dynamic_Predicate)
+ = Name_Ignore);
+
elsif A_Id = Aspect_Static_Predicate then
Set_Has_Static_Predicate_Aspect (E);
elsif A_Id = Aspect_Ghost_Predicate then
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 671b2a542ea..6d4ec122a21 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -12030,6 +12030,18 @@ package body Sem_Prag is
Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
Set_Is_Checked (N, Is_Checked (Original_Node (N)));
+ -- Skip querying the applicable policy at this point for dynamic
+ -- predicate checks since they rely on the policy applicable in
+ -- the context of their associated type declaration (and this
+ -- pragma check has been internally added by the frontend at the
+ -- point where the runtime check must be performed).
+
+ elsif not Comes_From_Source (N)
+ and then Chars (Pragma_Identifier (N)) = Name_Check
+ and then Pname = Name_Dynamic_Predicate
+ then
+ null;
+
-- Otherwise query the applicable policy at this point
else
@@ -14420,6 +14432,62 @@ package body Sem_Prag is
-- restore the Ghost mode.
when Pragma_Check => Check : declare
+
+ procedure Handle_Dynamic_Predicate_Check;
+ -- Enable or ignore the pragma depending on whether dynamic
+ -- checks are enabled in the context where the associated
+ -- type declaration is defined.
+
+ ------------------------------------
+ -- Handle_Dynamic_Predicate_Check --
+ ------------------------------------
+
+ procedure Handle_Dynamic_Predicate_Check is
+ Func_Call : constant Node_Id := Expression (Arg2);
+ Func_Id : constant Entity_Id := Entity (Name (Func_Call));
+ Typ : Entity_Id;
+
+ begin
+ -- Locate the type declaration associated with this runtime
+ -- check. The 2nd parameter of this pragma is a call to an
+ -- internally built function that has a single parameter;
+ -- the type of that formal parameter is the type we are
+ -- searching for.
+
+ pragma Assert (Is_Predicate_Function (Func_Id));
+ Typ := Etype (First_Entity (Func_Id));
+
+ if not Has_Dynamic_Predicate_Aspect (Typ)
+ and then Is_Private_Type (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ pragma Assert (Has_Dynamic_Predicate_Aspect (Typ));
+
+ if not Predicates_Ignored (Typ) then
+ Set_Is_Checked (N, True);
+ Set_Is_Ignored (N, False);
+
+ else
+ -- In CodePeer mode and GNATprove mode, we need to
+ -- consider all assertions, unless they are disabled,
+ -- because transformations of the AST may depend on
+ -- assertions being checked.
+
+ if CodePeer_Mode or GNATprove_Mode then
+ Set_Is_Checked (N, True);
+ Set_Is_Ignored (N, False);
+ else
+ Set_Is_Checked (N, False);
+ Set_Is_Ignored (N, True);
+ end if;
+ end if;
+ end Handle_Dynamic_Predicate_Check;
+
+ -- Local variables
+
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
-- Save the Ghost-related attributes to restore on exit
@@ -14430,6 +14498,8 @@ package body Sem_Prag is
Str : Node_Id;
pragma Warnings (Off, Str);
+ -- Start of processing for Pragma_Check
+
begin
-- Pragma Check is Ghost when it applies to a Ghost entity. Set
-- the mode now to ensure that any nodes generated during analysis
@@ -14484,6 +14554,16 @@ package body Sem_Prag is
Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
Set_Is_Checked (N, Is_Checked (Original_Node (N)));
+ -- Internally added dynamic predicate checks require checking the
+ -- applicable policy at the point of the type declaration of their
+ -- corresponding entity.
+
+ elsif not Comes_From_Source (N)
+ and then Chars (Pragma_Identifier (N)) = Name_Check
+ and then Pname = Name_Dynamic_Predicate
+ then
+ Handle_Dynamic_Predicate_Check;
+
-- Otherwise query the applicable policy at this point
else
@@ -22279,8 +22359,22 @@ package body Sem_Prag is
Set_Has_Delayed_Aspects (Typ);
Set_Has_Delayed_Freeze (Typ);
- Set_Predicates_Ignored (Typ,
- Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
+ -- Mark this aspect as ignored if the policy in effect is Ignore.
+
+ -- It is not done for the internally built pragma created as part
+ -- of processing aspect dynamic predicate because, in such case,
+ -- this was done when the aspect was processed (see subprogram
+ -- Analyze_One_Aspect).
+
+ if From_Aspect_Specification (N)
+ and then Pname = Name_Dynamic_Predicate
+ then
+ null;
+ else
+ Set_Predicates_Ignored (Typ,
+ Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
+ end if;
+
Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
end Predicate;
--
2.45.1
