exp_attr.adb (Expand_N_Attribute_Reference): Apply a predicate check when evaluating...

2012-11-06  Gary Dismukes  <dismukes@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Apply a predicate
	check when evaluating the attribute Valid, and issue a warning
	about infinite recursion when the check occurs within the
	predicate function of the prefix's subtype.
	* exp_ch4.adb (Expand_N_In): Remove test for Is_Discrete_Type
	when we're checking that there's no predicate check function as a
	condition for substituting a Valid check for a scalar membership
	test (substitution should be suppressed for any kind of scalar
	subtype with a predicate check). Also, don't emit a predicate
	check when the right operand is a range.

From-SVN: r193228

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index e3c04aa..7493c6d 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2012-11-06  Gary Dismukes  <dismukes@adacore.com>
+
+       * exp_attr.adb (Expand_N_Attribute_Reference): Apply a predicate
+       check when evaluating the attribute Valid, and issue a warning
+       about infinite recursion when the check occurs within the
+       predicate function of the prefix's subtype.
+       * exp_ch4.adb (Expand_N_In): Remove test for Is_Discrete_Type
+       when we're checking that there's no predicate check function as a
+       condition for substituting a Valid check for a scalar membership
+       test (substitution should be suppressed for any kind of scalar
+       subtype with a predicate check). Also, don't emit a predicate
+       check when the right operand is a range.
+
 2012-11-06  Robert Dewar  <dewar@adacore.com>
 
        * par_sco.adb, bindgen.adb, exp_vfpt.adb, exp_vfpt.ads, exp_ch2.adb,

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 417bad9..d94ae88 100644 (file)
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -27,6 +27,7 @@ with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
+with Errout;   use Errout;
 with Exp_Atag; use Exp_Atag;
 with Exp_Ch2;  use Exp_Ch2;
 with Exp_Ch3;  use Exp_Ch3;
@@ -5608,6 +5609,32 @@ package body Exp_Attr is
             Rewrite (N, Make_Range_Test);
          end if;
 
+         --  If a predicate is present, then we do the predicate test, even if
+         --  within the predicate function (infinite recursion is warned about
+         --  in that case).
+
+         declare
+            Pred_Func : constant Entity_Id := Predicate_Function (Ptyp);
+
+         begin
+            if Present (Pred_Func) then
+               Rewrite (N,
+                 Make_And_Then (Loc,
+                   Left_Opnd  => Relocate_Node (N),
+                   Right_Opnd => Make_Predicate_Call (Ptyp, Pref)));
+
+               --  If the attribute appears within the subtype's own predicate
+               --  function, then issue a warning that this will cause infinite
+               --  recursion.
+
+               if Current_Scope = Pred_Func then
+                  Error_Msg_N
+                    ("attribute Valid requires a predicate check?", N);
+                  Error_Msg_N ("\and will result in infinite recursion?", N);
+               end if;
+            end if;
+         end;
+
          Analyze_And_Resolve (N, Standard_Boolean);
          Validity_Checks_On := Save_Validity_Checks_On;
       end Valid;

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index ebdbcde..d9bdebd 100644 (file)
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -5565,8 +5565,7 @@ package body Exp_Ch4 is
         --  Skip this for predicated types, where such expressions are a
         --  reasonable way of testing if something meets the predicate.
 
-        and then not (Is_Discrete_Type (Ltyp)
-                       and then Present (Predicate_Function (Ltyp)))
+        and then not Present (Predicate_Function (Ltyp))
       then
          Substitute_Valid_Check;
          return;
@@ -6103,6 +6102,9 @@ package body Exp_Ch4 is
       --  If a predicate is present, then we do the predicate test, but we
       --  most certainly want to omit this if we are within the predicate
       --  function itself, since otherwise we have an infinite recursion!
+      --  The check should also not be emitted when testing against a range
+      --  (the check is only done when the right operand is a subtype; see
+      --  RM12-4.5.2 (28.1/3-30/3)).
 
       declare
          PFunc : constant Entity_Id := Predicate_Function (Rtyp);
@@ -6110,6 +6112,7 @@ package body Exp_Ch4 is
       begin
          if Present (PFunc)
            and then Current_Scope /= PFunc
+           and then Nkind (Rop) /= N_Range
          then
             Rewrite (N,
               Make_And_Then (Loc,