[Ada] Implement predicate checks on qualified expressions (AI12-0100)

2020-06-08  Gary Dismukes  <dismukes@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.

5 files changed, 61 insertions, 40 deletions

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 744c8a4..945c7d3 100644
--- a/gcc/ada/checks.adb
+++ b/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;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 8d6ddd7..8631ded 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/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;
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index d4a3ff8..2fab4bb 100644
--- a/gcc/ada/sem_eval.adb
+++ b/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;
 
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index ba84e54..984a75f 100644
--- a/gcc/ada/sem_eval.ads
+++ b/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
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 83cd20d..0856c89 100644
--- a/gcc/ada/sem_res.adb
+++ b/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