Predicate checks are required by AI12-0100 when evaluating qualified
expressions where the qualifying subtype has such checks. Errors rather
than warnings must be issued on static qualified expressions and type
conversions that violate a static predicate, so that's corrected here.
There were also cases where warnings were issued on statically
detectible violations but then checks were not generated, and that is
addressed by these changes as well.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-08 Gary Dismukes <dismu...@adacore.com>
gcc/ada/
* checks.adb (Apply_Predicate_Check): Refine test for being in a
subprogram body to account for no Corresponding_Body case,
avoiding blowups arising due to other changes here.
* exp_ch4.adb (Expand_N_Qualified_Expression): Apply predicate
checks, if any, after constraint checks are applied.
* sem_eval.ads (Check_Expression_Against_Static_Predicate): Add
Check_Failure_Is_Error formal for conditionalizing warning vs.
error messages.
* sem_eval.adb (Check_Expression_Against_Static_Predicate):
Issue an error message rather than a warning when the new
Check_Failure_Is_Error formal is True. In the nonstatic or
Dynamic_Predicate case where the predicate is known to fail,
emit the check to ensure that folded cases get checks applied.
* sem_res.adb (Resolve_Qualified_Expression): Call
Check_Expression_Against_Static_Predicate, passing True for
Check_Failure_Is_Error, to ensure we reject static predicate
violations. Remove code that was conditionally calling
Apply_Predicate_Check, which is no longer needed, and that check
procedure shouldn't be called from a resolution routine in any
case. Also remove associated comment about preventing infinite
recursion and consistency with Resolve_Type_Conversion, since
that handling was already similarly removed from
Resolve_Type_Convesion at some point.
(Resolve_Type_Conversion): Add passing of True for
Check_Failure_Is_Error parameter on call to
Check_Expression_Against_Static_Predicate, to ensure that static
conversion cases that violate a predicate are rejected as
errors.--- gcc/ada/checks.adb
+++ gcc/ada/checks.adb
@@ -2789,7 +2789,13 @@ package body Checks is
begin
while Present (P) loop
if Nkind (P) = N_Subprogram_Body
- and then Corresponding_Spec (P) = Scope (Entity (N))
+ and then
+ ((Present (Corresponding_Spec (P))
+ and then
+ Corresponding_Spec (P) = Scope (Entity (N)))
+ or else
+ Defining_Unit_Name (Specification (P)) =
+ Scope (Entity (N)))
then
In_Body := True;
exit;
--- gcc/ada/exp_ch4.adb
+++ gcc/ada/exp_ch4.adb
@@ -10424,6 +10424,10 @@ package body Exp_Ch4 is
Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
+ -- Apply possible predicate check
+
+ Apply_Predicate_Check (Operand, Target_Type);
+
if Do_Range_Check (Operand) then
Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
end if;
--- gcc/ada/sem_eval.adb
+++ gcc/ada/sem_eval.adb
@@ -324,8 +324,9 @@ package body Sem_Eval is
-----------------------------------------------
procedure Check_Expression_Against_Static_Predicate
- (Expr : Node_Id;
- Typ : Entity_Id)
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Static_Failure_Is_Error : Boolean := False)
is
begin
-- Nothing to do if expression is not known at compile time, or the
@@ -383,18 +384,28 @@ package body Sem_Eval is
-- Here we know that the predicate will fail
-- Special case of static expression failing a predicate (other than one
- -- that was explicitly specified with a Dynamic_Predicate aspect). This
- -- is the case where the expression is no longer considered static.
+ -- that was explicitly specified with a Dynamic_Predicate aspect). If
+ -- the expression comes from a qualified_expression or type_conversion
+ -- this is an error (Static_Failure_Is_Error); otherwise we only issue
+ -- a warning and the expression is no longer considered static.
if Is_Static_Expression (Expr)
and then not Has_Dynamic_Predicate_Aspect (Typ)
then
- Error_Msg_NE
- ("??static expression fails static predicate check on &",
- Expr, Typ);
- Error_Msg_N
- ("\??expression is no longer considered static", Expr);
- Set_Is_Static_Expression (Expr, False);
+ if Static_Failure_Is_Error then
+ Error_Msg_NE
+ ("static expression fails static predicate check on &",
+ Expr, Typ);
+
+ else
+ Error_Msg_NE
+ ("??static expression fails static predicate check on &",
+ Expr, Typ);
+ Error_Msg_N
+ ("\??expression is no longer considered static", Expr);
+
+ Set_Is_Static_Expression (Expr, False);
+ end if;
-- In all other cases, this is just a warning that a test will fail.
-- It does not matter if the expression is static or not, or if the
@@ -403,6 +414,15 @@ package body Sem_Eval is
else
Error_Msg_NE
("??expression fails predicate check on &", Expr, Typ);
+
+ -- Force a check here, which is potentially a redundant check, but
+ -- this ensures a check will be done in cases where the expression
+ -- is folded, and since this is definitely a failure, extra checks
+ -- are OK.
+
+ Insert_Action (Expr,
+ Make_Predicate_Check
+ (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks);
end if;
end Check_Expression_Against_Static_Predicate;
--- gcc/ada/sem_eval.ads
+++ gcc/ada/sem_eval.ads
@@ -125,15 +125,18 @@ package Sem_Eval is
-----------------
procedure Check_Expression_Against_Static_Predicate
- (Expr : Node_Id;
- Typ : Entity_Id);
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Static_Failure_Is_Error : Boolean := False);
-- Determine whether an arbitrary expression satisfies the static predicate
-- of a type. The routine does nothing if Expr is not known at compile time
- -- or Typ lacks a static predicate, otherwise it may emit a warning if the
- -- expression is prohibited by the predicate. If the expression is a static
- -- expression and it fails a predicate that was not explicitly stated to be
- -- a dynamic predicate, then an additional warning is given, and the flag
- -- Is_Static_Expression is reset on Expr.
+ -- or Typ lacks a static predicate; otherwise it may emit a warning if the
+ -- expression is prohibited by the predicate, or if Static_Failure_Is_Error
+ -- is True then an error will be flagged. If the expression is a static
+ -- expression, it fails a predicate that was not explicitly stated to be
+ -- a dynamic predicate, and Static_Failure_Is_Error is False, then an
+ -- additional warning is given, and the flag Is_Static_Expression is reset
+ -- on Expr.
procedure Check_Non_Static_Context (N : Node_Id);
-- Deals with the special check required for a static expression that
--- gcc/ada/sem_res.adb
+++ gcc/ada/sem_res.adb
@@ -10008,27 +10008,13 @@ package body Sem_Res is
Apply_Scalar_Range_Check (Expr, Typ);
end if;
- -- Finally, check whether a predicate applies to the target type. This
- -- comes from AI12-0100. As for type conversions, check the enclosing
- -- context to prevent an infinite expansion.
+ -- AI12-0100: Once the qualified expression is resolved, check whether
+ -- operand statisfies a static predicate of the target subtype, if any.
+ -- In the static expression case, a predicate check failure is an error.
if Has_Predicates (Target_Typ) then
- if Nkind (Parent (N)) = N_Function_Call
- and then Present (Name (Parent (N)))
- and then (Is_Predicate_Function (Entity (Name (Parent (N))))
- or else
- Is_Predicate_Function_M (Entity (Name (Parent (N)))))
- then
- null;
-
- -- In the case of a qualified expression in an allocator, the check
- -- is applied when expanding the allocator, so avoid redundant check.
-
- elsif Nkind (N) = N_Qualified_Expression
- and then Nkind (Parent (N)) /= N_Allocator
- then
- Apply_Predicate_Check (N, Target_Typ);
- end if;
+ Check_Expression_Against_Static_Predicate
+ (N, Target_Typ, Static_Failure_Is_Error => True);
end if;
end Resolve_Qualified_Expression;
@@ -11553,11 +11539,13 @@ package body Sem_Res is
end;
end if;
- -- Ada 2012: once the type conversion is resolved, check whether the
- -- operand statisfies the static predicate of the target type.
+ -- Ada 2012: Once the type conversion is resolved, check whether the
+ -- operand statisfies a static predicate of the target subtype, if any.
+ -- In the static expression case, a predicate check failure is an error.
if Has_Predicates (Target_Typ) then
- Check_Expression_Against_Static_Predicate (N, Target_Typ);
+ Check_Expression_Against_Static_Predicate
+ (N, Target_Typ, Static_Failure_Is_Error => True);
end if;
-- If at this stage we have a real to integer conversion, make sure that
