2013-04-25 Arnaud Charlet <charlet@adacore.com>

	* par-prag.adb: Fix typo.

2013-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* checks.adb (Apply_Predicate_Check): If the type has a static
	predicate and the expression is also static, check whether the
	expression satisfies the predicate.
	* sem_ch3.adb (Analyze_Object_Declaration): If the type has a
	static predicate and the expression is also static, see if the
	expression satisfies the predicate.
	* sem_util.adb: Alphabetize several routines.
	(Check_Expression_Against_Static_Predicate): New routine.
	* sem_util.ads (Check_Expression_Against_Static_Predicate): New routine.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@198296 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 149 insertions, 102 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 3c3d7dbc0ed..69141c3f243 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,19 @@
+2013-04-25  Arnaud Charlet  <charlet@adacore.com>
+
+	* par-prag.adb: Fix typo.
+
+2013-04-25  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* checks.adb (Apply_Predicate_Check): If the type has a static
+	predicate and the expression is also static, check whether the
+	expression satisfies the predicate.
+	* sem_ch3.adb (Analyze_Object_Declaration): If the type has a
+	static predicate and the expression is also static, see if the
+	expression satisfies the predicate.
+	* sem_util.adb: Alphabetize several routines.
+	(Check_Expression_Against_Static_Predicate): New routine.
+	* sem_util.ads (Check_Expression_Against_Static_Predicate): New routine.
+
 2013-04-25  Robert Dewar  <dewar@adacore.com>
 
 	* gnat_rm.texi: Document Reason argument for pragma Warnings.
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 3cb1f95da8b..5a5b7d1fc7b 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -2502,29 +2502,10 @@ package body Checks is
          --  Here for normal case of predicate active
 
          else
-            --  If the predicate is a static predicate and the operand is
-            --  static, the predicate must be evaluated statically. If the
-            --  evaluation fails this is a static constraint error. This check
-            --  is disabled in -gnatc mode, because the compiler is incapable
-            --  of evaluating static expressions in that case. Note that when
-            --  inherited predicates are involved, a type may have both static
-            --  and dynamic forms. Check the presence of a dynamic predicate
-            --  aspect.
-
-            if Is_OK_Static_Expression (N)
-              and then Present (Static_Predicate (Typ))
-              and then not Has_Dynamic_Predicate_Aspect (Typ)
-            then
-               if Operating_Mode < Generate_Code
-                 or else Eval_Static_Predicate_Check (N, Typ)
-               then
-                  return;
-               else
-                  Error_Msg_NE
-                    ("static expression fails static predicate check on&",
-                     N, Typ);
-               end if;
-            end if;
+            --  If the type has a static predicate and the expression is also
+            --  static, see if the expression satisfies the predicate.
+
+            Check_Expression_Against_Static_Predicate (N, Typ);
 
             Insert_Action (N,
               Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index de262094a95..3587dff4d12 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -17,7 +17,7 @@
 -- for  more details.  You should have  received  a copy of the GNU General --
 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
 -- http://www.gnu.org/licenses for a complete copy of the license.          --
---          War                                                                --
+--                                                                          --
 -- GNAT was originally developed  by the GNAT team at  New York University. --
 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
 --                                                                          --
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index bd0a51901a6..08177737587 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3260,11 +3260,11 @@ package body Sem_Ch3 is
          end if;
       end if;
 
-      --  Deal with predicate check before we start to do major rewriting.
-      --  it is OK to initialize and then check the initialized value, since
-      --  the object goes out of scope if we get a predicate failure. Note
-      --  that we do this in the analyzer and not the expander because the
-      --  analyzer does some substantial rewriting in some cases.
+      --  Deal with predicate check before we start to do major rewriting. It
+      --  is OK to initialize and then check the initialized value, since the
+      --  object goes out of scope if we get a predicate failure. Note that we
+      --  do this in the analyzer and not the expander because the analyzer
+      --  does some substantial rewriting in some cases.
 
       --  We need a predicate check if the type has predicates, and if either
       --  there is an initializing expression, or for default initialization
@@ -3277,6 +3277,13 @@ package body Sem_Ch3 is
             or else
               Is_Partially_Initialized_Type (T, Include_Implicit => False))
       then
+         --  If the type has a static predicate and the expression is also
+         --  static, see if the expression satisfies the predicate.
+
+         if Present (E) then
+            Check_Expression_Against_Static_Predicate (E, T);
+         end if;
+
          Insert_After (N,
            Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
       end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index ab68c39f991..bc1f3fb8fd7 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -1265,6 +1265,114 @@ package body Sem_Util is
       end if;
    end Cannot_Raise_Constraint_Error;
 
+   -----------------------------------------
+   -- Check_Dynamically_Tagged_Expression --
+   -----------------------------------------
+
+   procedure Check_Dynamically_Tagged_Expression
+     (Expr        : Node_Id;
+      Typ         : Entity_Id;
+      Related_Nod : Node_Id)
+   is
+   begin
+      pragma Assert (Is_Tagged_Type (Typ));
+
+      --  In order to avoid spurious errors when analyzing the expanded code,
+      --  this check is done only for nodes that come from source and for
+      --  actuals of generic instantiations.
+
+      if (Comes_From_Source (Related_Nod)
+           or else In_Generic_Actual (Expr))
+        and then (Is_Class_Wide_Type (Etype (Expr))
+                   or else Is_Dynamically_Tagged (Expr))
+        and then Is_Tagged_Type (Typ)
+        and then not Is_Class_Wide_Type (Typ)
+      then
+         Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
+      end if;
+   end Check_Dynamically_Tagged_Expression;
+
+   -----------------------------------------------
+   -- Check_Expression_Against_Static_Predicate --
+   -----------------------------------------------
+
+   procedure Check_Expression_Against_Static_Predicate
+     (Expr : Node_Id;
+      Typ  : Entity_Id)
+   is
+   begin
+      --  When both the predicate and the expression are static, evaluate the
+      --  check at compile time. A type becomes non-static when it has aspect
+      --  Dynamic_Predicate.
+
+      if Is_OK_Static_Expression (Expr)
+        and then Has_Predicates (Typ)
+        and then Present (Static_Predicate (Typ))
+        and then not Has_Dynamic_Predicate_Aspect (Typ)
+      then
+         --  Either -gnatc is enabled or the expression is ok
+
+         if Operating_Mode < Generate_Code
+           or else Eval_Static_Predicate_Check (Expr, Typ)
+         then
+            null;
+
+         --  The expression is prohibited by the static predicate
+
+         else
+            Error_Msg_NE
+              ("?static expression fails static predicate check on &",
+               Expr, Typ);
+         end if;
+      end if;
+   end Check_Expression_Against_Static_Predicate;
+
+   --------------------------
+   -- Check_Fully_Declared --
+   --------------------------
+
+   procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
+   begin
+      if Ekind (T) = E_Incomplete_Type then
+
+         --  Ada 2005 (AI-50217): If the type is available through a limited
+         --  with_clause, verify that its full view has been analyzed.
+
+         if From_With_Type (T)
+           and then Present (Non_Limited_View (T))
+           and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
+         then
+            --  The non-limited view is fully declared
+            null;
+
+         else
+            Error_Msg_NE
+              ("premature usage of incomplete}", N, First_Subtype (T));
+         end if;
+
+      --  Need comments for these tests ???
+
+      elsif Has_Private_Component (T)
+        and then not Is_Generic_Type (Root_Type (T))
+        and then not In_Spec_Expression
+      then
+         --  Special case: if T is the anonymous type created for a single
+         --  task or protected object, use the name of the source object.
+
+         if Is_Concurrent_Type (T)
+           and then not Comes_From_Source (T)
+           and then Nkind (N) = N_Object_Declaration
+         then
+            Error_Msg_NE ("type of& has incomplete component", N,
+              Defining_Identifier (N));
+
+         else
+            Error_Msg_NE
+              ("premature usage of incomplete}", N, First_Subtype (T));
+         end if;
+      end if;
+   end Check_Fully_Declared;
+
    -------------------------------------
    -- Check_Function_Writable_Actuals --
    -------------------------------------
@@ -2016,79 +2124,6 @@ package body Sem_Util is
       end loop Outer;
    end Check_Later_Vs_Basic_Declarations;
 
-   -----------------------------------------
-   -- Check_Dynamically_Tagged_Expression --
-   -----------------------------------------
-
-   procedure Check_Dynamically_Tagged_Expression
-     (Expr        : Node_Id;
-      Typ         : Entity_Id;
-      Related_Nod : Node_Id)
-   is
-   begin
-      pragma Assert (Is_Tagged_Type (Typ));
-
-      --  In order to avoid spurious errors when analyzing the expanded code,
-      --  this check is done only for nodes that come from source and for
-      --  actuals of generic instantiations.
-
-      if (Comes_From_Source (Related_Nod)
-           or else In_Generic_Actual (Expr))
-        and then (Is_Class_Wide_Type (Etype (Expr))
-                   or else Is_Dynamically_Tagged (Expr))
-        and then Is_Tagged_Type (Typ)
-        and then not Is_Class_Wide_Type (Typ)
-      then
-         Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
-      end if;
-   end Check_Dynamically_Tagged_Expression;
-
-   --------------------------
-   -- Check_Fully_Declared --
-   --------------------------
-
-   procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
-   begin
-      if Ekind (T) = E_Incomplete_Type then
-
-         --  Ada 2005 (AI-50217): If the type is available through a limited
-         --  with_clause, verify that its full view has been analyzed.
-
-         if From_With_Type (T)
-           and then Present (Non_Limited_View (T))
-           and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
-         then
-            --  The non-limited view is fully declared
-            null;
-
-         else
-            Error_Msg_NE
-              ("premature usage of incomplete}", N, First_Subtype (T));
-         end if;
-
-      --  Need comments for these tests ???
-
-      elsif Has_Private_Component (T)
-        and then not Is_Generic_Type (Root_Type (T))
-        and then not In_Spec_Expression
-      then
-         --  Special case: if T is the anonymous type created for a single
-         --  task or protected object, use the name of the source object.
-
-         if Is_Concurrent_Type (T)
-           and then not Comes_From_Source (T)
-           and then Nkind (N) = N_Object_Declaration
-         then
-            Error_Msg_NE ("type of& has incomplete component", N,
-              Defining_Identifier (N));
-
-         else
-            Error_Msg_NE
-              ("premature usage of incomplete}", N, First_Subtype (T));
-         end if;
-      end if;
-   end Check_Fully_Declared;
-
    -------------------------
    -- Check_Nested_Access --
    -------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index d6d1ecc2deb..b5d1ed355c4 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -191,6 +191,14 @@ package Sem_Util is
       Related_Nod : Node_Id);
    --  Check wrong use of dynamically tagged expression
 
+   procedure Check_Expression_Against_Static_Predicate
+     (Expr : Node_Id;
+      Typ  : Entity_Id);
+   --  Determine whether an arbitrary expression satisfies the static predicate
+   --  of a type. The routine does nothing if Expr is non-static or Typ lacks a
+   --  static predicate, otherwise it may emit a warning if the expression is
+   --  prohibited by the predicate.
+
    procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id);
    --  Verify that the full declaration of type T has been seen. If not, place
    --  error message on node N. Used in object declarations, type conversions