einfo.ads, einfo.adb (Static_Real_Or_String_Predicate): New function

2014-07-29  Robert Dewar  <dewar@adacore.com>

	* einfo.ads, einfo.adb (Static_Real_Or_String_Predicate): New function
	(Set_Static_Real_Or_String_Predicate): New procedure
	* sem_ch13.adb (Build_Predicate_Functions): Accomodate static
	string predicates (Is_Predicate_Static): Handle static string
	predicates.
	* sem_eval.adb (Real_Or_String_Static_Predicate_Matches):
	New procedure (Check_Expression_Against_Static_Predicate):
	Deal with static string predicates, now fully implemented
	(Eval_Relational_Op): Allow string equality/inequality as static
	if not comes from source.

From-SVN: r213162

5 files changed, 247 insertions, 34 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index e598c0c..9aa5cb0 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,18 @@
 2014-07-29  Robert Dewar  <dewar@adacore.com>
 
+	* einfo.ads, einfo.adb (Static_Real_Or_String_Predicate): New function
+	(Set_Static_Real_Or_String_Predicate): New procedure
+	* sem_ch13.adb (Build_Predicate_Functions): Accomodate static
+	string predicates (Is_Predicate_Static): Handle static string
+	predicates.
+	* sem_eval.adb (Real_Or_String_Static_Predicate_Matches):
+	New procedure (Check_Expression_Against_Static_Predicate):
+	Deal with static string predicates, now fully implemented
+	(Eval_Relational_Op): Allow string equality/inequality as static
+	if not comes from source.
+
+2014-07-29  Robert Dewar  <dewar@adacore.com>
+
 	* sem_aggr.adb, exp_ch5.adb, sem_ch5.adb, exp_util.adb, einfo.adb,
 	einfo.ads, sem_util.adb, sem_attr.adb, sem_case.adb, sem_eval.adb,
 	sem_eval.ads, sem_ch13.adb: General cleanup of static predicate
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index ac62412..5da314a 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -223,6 +223,7 @@ package body Einfo is
    --    PPC_Wrapper                     Node25
    --    Related_Array_Object            Node25
    --    Static_Discrete_Predicate       List25
+   --    Static_Real_Or_String_Predicate Node25
    --    Task_Body_Procedure             Node25
 
    --    Dispatch_Table_Wrappers         Elist26
@@ -2977,6 +2978,12 @@ package body Einfo is
       return List25 (Id);
    end Static_Discrete_Predicate;
 
+   function Static_Real_Or_String_Predicate (Id : E) return N is
+   begin
+      pragma Assert (Is_Real_Type (Id) or else Is_String_Type (Id));
+      return Node25 (Id);
+   end Static_Real_Or_String_Predicate;
+
    function Status_Flag_Or_Transient_Decl (Id : E) return N is
    begin
       pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
@@ -5767,6 +5774,13 @@ package body Einfo is
       Set_List25 (Id, V);
    end Set_Static_Discrete_Predicate;
 
+   procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N) is
+   begin
+      pragma Assert ((Is_Real_Type (Id) or else Is_String_Type (Id))
+                      and then Has_Predicates (Id));
+      Set_Node25 (Id, V);
+   end Set_Static_Real_Or_String_Predicate;
+
    procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is
    begin
       pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
@@ -9399,13 +9413,12 @@ package body Einfo is
               E_Entry_Family                               =>
             Write_Str ("PPC_Wrapper");
 
-         when E_Enumeration_Type                           |
-              E_Enumeration_Subtype                        |
-              E_Modular_Integer_Type                       |
-              E_Modular_Integer_Subtype                    |
-              E_Signed_Integer_Subtype                     =>
+         when Discrete_Kind                                =>
             Write_Str ("Static_Discrete_Predicate");
 
+         when Real_Kind                                    =>
+            Write_Str ("Static_Real_Or_String_Predicate");
+
          when others                                       =>
             Write_Str ("Field25??");
       end case;
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index d6f7d7d..41f134c 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3899,7 +3899,7 @@ package Einfo is
 
 --    Static_Discrete_Predicate (List25)
 --       Defined in discrete types/subtypes with static predicates (with the
---       two flags Has_Predicates set and Has_Static_Predicate set). Set if the
+--       two flags Has_Predicates and Has_Static_Predicate set). Set if the
 --       type/subtype has a static predicate. Points to a list of expression
 --       and N_Range nodes that represent the predicate in canonical form. The
 --       canonical form has entries sorted in ascending order, with duplicates
@@ -3908,6 +3908,26 @@ package Einfo is
 --       are fully analyzed and typed with the base type of the subtype. Note
 --       that all entries are static and have values within the subtype range.
 
+--    Static_Real_Or_String_Predicate (Node25)
+--       Defined in real types/subtypes with static predicates (with the two
+--       flags Has_Predicates and Has_Static_Predicate set). Set if the type
+--       or subtype has a static predicate. Points to the return expression
+--       of the predicate function. This is the original expression given as
+--       the predicate except that occurrences of the type are replaced by
+--       occurrences of the formal parameter of the predicate function (note
+--       that the spec of this function including this formal parameter name)
+--       is available from the Subprograms_For_Type field (it can be accessed
+--       as Predicate_Function (typ). Also, in the case where a predicate is
+--       inherited, the expression is of the form:
+--
+--         expression AND THEN xxxPredicate (typ2 (ent))
+--
+--       where typ2 is the type from which the predicate is inherited, ent is
+--       the entity for the current predicate function, and xxxPredicate is the
+--       inherited predicate (from typ2). Finally for a predicate that inherits
+--       from another predicate but does not add a predicate of its own, the
+--       expression may consist of the above xxxPredicate call on its own.
+
 --    Status_Flag_Or_Transient_Decl (Node15)
 --       Defined in variables and constants. Applies to objects that require
 --       special treatment by the finalization machinery, such as extended
@@ -5452,6 +5472,7 @@ package Einfo is
    --    Scalar_Range                        (Node20)
    --    Delta_Value                         (Ureal18)
    --    Small_Value                         (Ureal21)
+   --    Static_Real_Or_String_Predicate     (Node25)
    --    Has_Machine_Radix_Clause            (Flag83)
    --    Machine_Radix_10                    (Flag84)
    --    Aft_Value                           (synth)
@@ -5557,6 +5578,7 @@ package Einfo is
    --    Float_Rep                           (Uint10)   (Float_Rep_Kind)
    --    Default_Aspect_Value                (Node19)   (base type only)
    --    Scalar_Range                        (Node20)
+   --    Static_Real_Or_String_Predicate     (Node25)
    --    Machine_Emax_Value                  (synth)
    --    Machine_Emin_Value                  (synth)
    --    Machine_Mantissa_Value              (synth)
@@ -5777,6 +5799,7 @@ package Einfo is
    --    Delta_Value                         (Ureal18)
    --    Default_Aspect_Value                (Node19)   (base type only)
    --    Scalar_Range                        (Node20)
+   --    Static_Real_Or_String_Predicate     (Node25)
    --    Small_Value                         (Ureal21)
    --    Has_Small_Clause                    (Flag67)
    --    Aft_Value                           (synth)
@@ -6048,6 +6071,7 @@ package Einfo is
    --  E_String_Subtype
    --    First_Index                         (Node17)
    --    Component_Type                      (Node20)   (base type only)
+   --    Static_Real_Or_String_Predicate     (Node25)
    --    Is_Constrained                      (Flag12)
    --    Next_Index                          (synth)
    --    Number_Dimensions                   (synth)
@@ -6791,6 +6815,7 @@ package Einfo is
    function Static_Elaboration_Desired          (Id : E) return B;
    function Static_Initialization               (Id : E) return N;
    function Static_Discrete_Predicate           (Id : E) return S;
+   function Static_Real_Or_String_Predicate     (Id : E) return N;
    function Status_Flag_Or_Transient_Decl       (Id : E) return E;
    function Storage_Size_Variable               (Id : E) return E;
    function Stored_Constraint                   (Id : E) return L;
@@ -7425,6 +7450,7 @@ package Einfo is
    procedure Set_Static_Elaboration_Desired      (Id : E; V : B);
    procedure Set_Static_Initialization           (Id : E; V : N);
    procedure Set_Static_Discrete_Predicate       (Id : E; V : S);
+   procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N);
    procedure Set_Status_Flag_Or_Transient_Decl   (Id : E; V : E);
    procedure Set_Storage_Size_Variable           (Id : E; V : E);
    procedure Set_Stored_Constraint               (Id : E; V : L);
@@ -8209,6 +8235,7 @@ package Einfo is
    pragma Inline (Static_Elaboration_Desired);
    pragma Inline (Static_Initialization);
    pragma Inline (Static_Discrete_Predicate);
+   pragma Inline (Static_Real_Or_String_Predicate);
    pragma Inline (Status_Flag_Or_Transient_Decl);
    pragma Inline (Storage_Size_Variable);
    pragma Inline (Stored_Constraint);
@@ -8642,6 +8669,7 @@ package Einfo is
    pragma Inline (Set_Static_Elaboration_Desired);
    pragma Inline (Set_Static_Initialization);
    pragma Inline (Set_Static_Discrete_Predicate);
+   pragma Inline (Set_Static_Real_Or_String_Predicate);
    pragma Inline (Set_Status_Flag_Or_Transient_Decl);
    pragma Inline (Set_Storage_Size_Variable);
    pragma Inline (Set_Stored_Constraint);
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index e0c6782..73dc3c5 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -8002,10 +8002,16 @@ package body Sem_Ch13 is
          --  yes even if we have an explicit Dynamic_Predicate present.
 
          declare
-            PS : constant Boolean := Is_Predicate_Static (Expr, Object_Name);
+            PS : Boolean;
             EN : Node_Id;
 
          begin
+            if not Is_Scalar_Type (Typ) and then not Is_String_Type (Typ) then
+               PS := False;
+            else
+               PS := Is_Predicate_Static (Expr, Object_Name);
+            end if;
+
             --  Case where we have a predicate-static aspect
 
             if PS then
@@ -8033,6 +8039,11 @@ package body Sem_Ch13 is
                   if No (Static_Discrete_Predicate (Typ)) then
                      Set_Has_Static_Predicate (Typ, False);
                   end if;
+
+               --  For real or string subtype, save predicate expression
+
+               elsif Is_Real_Type (Typ) or else Is_String_Type (Typ) then
+                  Set_Static_Real_Or_String_Predicate (Typ, Expr);
                end if;
 
             --  Case of dynamic predicate (expression is not predicate-static)
@@ -8060,14 +8071,13 @@ package body Sem_Ch13 is
                --  Now post appropriate message
 
                if Has_Static_Predicate_Aspect (Typ) then
-                  if Is_Scalar_Type (Typ) then
+                  if Is_Scalar_Type (Typ) or else Is_String_Type (Typ) then
                      Error_Msg_F
                        ("expression is not predicate-static (RM 4.3.2(16-22))",
                         EN);
                   else
-                     Error_Msg_FE
-                       ("static predicate not allowed for non-scalar type&",
-                        EN, Typ);
+                     Error_Msg_F
+                       ("static predicate requires scalar or string type", EN);
                   end if;
                end if;
             end if;
@@ -10362,6 +10372,9 @@ package body Sem_Ch13 is
    -- Is_Predicate_Static --
    -------------------------
 
+   --  Note: the basic legality of the expression has already been checked, so
+   --  we don't need to worry about cases or ranges on strings for example.
+
    function Is_Predicate_Static
      (Expr : Node_Id;
       Nam  : Name_Id) return Boolean
@@ -10462,12 +10475,6 @@ package body Sem_Ch13 is
    --  Start of processing for Is_Predicate_Static
 
    begin
-      --  Only scalar types can be predicate-static
-
-      if not Is_Scalar_Type (Etype (Expr)) then
-         return False;
-      end if;
-
       --  Predicate_Static means one of the following holds. Numbers are the
       --  corresponding paragraph numbers in (RM 3.2.4(16-22)).
 
@@ -10502,7 +10509,20 @@ package body Sem_Ch13 is
       --  operand is the current instance, and the other is a static
       --  expression.
 
+      --  Note: the RM is clearly wrong here in not excluding string types.
+      --  Without this exclusion, we would allow expressions like X > "ABC"
+      --  to be considered as predicate-static, which is clearly not intended,
+      --  since the idea is for predicate-static to be a subset of normal
+      --  static expressions (and "DEF" > "ABC" is not a static expression).
+
+      --  However, we do allow internally generated (not from source) equality
+      --  and inequality operations to be valid on strings (this helps deal
+      --  with cases where we transform A in "ABC" to A = "ABC).
+
       elsif Nkind (Expr) in N_Op_Compare
+        and then ((not Is_String_Type (Etype (Left_Opnd (Expr))))
+                    or else (Nkind_In (Expr, N_Op_Eq, N_Op_Ne)
+                              and then not Comes_From_Source (Expr)))
         and then ((Is_Type_Ref (Left_Opnd (Expr))
                     and then Is_OK_Static_Expression (Right_Opnd (Expr)))
                   or else
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 57152ae..44344ce 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -227,6 +227,16 @@ package body Sem_Eval is
    --  this is an illegality if N is static, and should generate a warning
    --  otherwise.
 
+   function Real_Or_String_Static_Predicate_Matches
+     (Val : Node_Id;
+      Typ : Entity_Id) return Boolean;
+   --  This is the function used to evaluate real or string static predicates.
+   --  Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
+   --  represents the value to be tested against the predicate. Typ is the
+   --  type with the predicate, from which the predicate expression can be
+   --  extracted. The result returned is True if the given value satisfies
+   --  the predicate.
+
    procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
    --  N and Exp are nodes representing an expression, Exp is known to raise
    --  CE. N is rewritten in term of Exp in the optimal way.
@@ -339,23 +349,36 @@ package body Sem_Eval is
       --  an explicitly specified Dynamic_Predicate whose expression met the
       --  rules for being predicate-static).
 
-      --  If we are not generating code, nothing more to do (why???)
+      --  Case of real static predicate
 
-      if Operating_Mode < Generate_Code then
-         return;
-      end if;
+      if Is_Real_Type (Typ) then
+         if Real_Or_String_Static_Predicate_Matches
+              (Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)),
+               Typ => Typ)
+         then
+            return;
+         end if;
 
-      --  If we have the real case, then for now, not implemented
+      --  Case of string static predicate
 
-      if not Is_Discrete_Type (Typ) then
-         Error_Msg_N ("??real predicate not applied", Expr);
-         return;
-      end if;
+      elsif Is_String_Type (Typ) then
+         if Real_Or_String_Static_Predicate_Matches
+           (Val => Expr_Value_S (Expr),
+            Typ => Typ)
+         then
+            return;
+         end if;
 
-      --  If static predicate matches, nothing to do
+      --  Case of discrete static predicate
 
-      if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
-         return;
+      else
+         pragma Assert (Is_Discrete_Type (Typ));
+
+         --  If static predicate matches, nothing to do
+
+         if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
+            return;
+         end if;
       end if;
 
       --  Here we know that the predicate will fail
@@ -3052,6 +3075,10 @@ package body Sem_Eval is
    --  both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
    --  the result is never static, even if the operands are.
 
+   --  However, for internally generated nodes, we allow string equality and
+   --  inequality to be static. This is because we rewrite A in "ABC" as an
+   --  equality test A = "ABC", and the former is definitely static.
+
    procedure Eval_Relational_Op (N : Node_Id) is
       Left   : constant Node_Id   := Left_Opnd (N);
       Right  : constant Node_Id   := Right_Opnd (N);
@@ -3289,9 +3316,16 @@ package body Sem_Eval is
 
          --  Only comparisons of scalars can give static results. In
          --  particular, comparisons of strings never yield a static
-         --  result, even if both operands are static strings.
+         --  result, even if both operands are static strings, except that
+         --  as noted above, we allow equality/inequality for strings.
+
+         if Is_String_Type (Typ)
+           and then not Comes_From_Source (N)
+           and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
+         then
+            null;
 
-         if not Is_Scalar_Type (Typ) then
+         elsif not Is_Scalar_Type (Typ) then
             Is_Static_Expression := False;
             Set_Is_Static_Expression (N, False);
          end if;
@@ -3307,9 +3341,8 @@ package body Sem_Eval is
             Otype := Find_Universal_Operator_Type (N);
          end if;
 
-         --  For static real type expressions, we cannot use
-         --  Compile_Time_Compare since it worries about run-time
-         --  results which are not exact.
+         --  For static real type expressions, do not use Compile_Time_Compare
+         --  since it worries about run-time results which are not exact.
 
          if Is_Static_Expression and then Is_Real_Type (Typ) then
             declare
@@ -5322,6 +5355,112 @@ package body Sem_Eval is
       end if;
    end Predicates_Match;
 
+   ---------------------------------------------
+   -- Real_Or_String_Static_Predicate_Matches --
+   ---------------------------------------------
+
+   function Real_Or_String_Static_Predicate_Matches
+     (Val : Node_Id;
+      Typ : Entity_Id) return Boolean
+   is
+      Expr : constant Node_Id := Static_Real_Or_String_Predicate (Typ);
+      --  The predicate expression from the type
+
+      Pfun : constant Entity_Id := Predicate_Function (Typ);
+      --  The entity for the predicate function
+
+      Ent_Name : constant Name_Id := Chars (First_Formal (Pfun));
+      --  The name of the formal of the predicate function. Occurrences of the
+      --  type name in Expr have been rewritten as references to this formal,
+      --  and it has a unique name, so we can identify references by this name.
+
+      Copy : Node_Id;
+      --  Copy of the predicate function tree
+
+      function Process (N : Node_Id) return Traverse_Result;
+      --  Function used to process nodes during the traversal in which we will
+      --  find occurrences of the entity name, and replace such occurrences
+      --  by a real literal with the value to be tested.
+
+      procedure Traverse is new Traverse_Proc (Process);
+      --  The actual traversal procedure
+
+      -------------
+      -- Process --
+      -------------
+
+      function Process (N : Node_Id) return Traverse_Result is
+      begin
+         if Nkind (N) = N_Identifier and then Chars (N) = Ent_Name then
+            declare
+               Nod : constant Node_Id := New_Copy (Val);
+            begin
+               Set_Sloc (Nod, Sloc (N));
+               Rewrite (N, Nod);
+               return Skip;
+            end;
+
+         else
+            return OK;
+         end if;
+      end Process;
+
+   --  Start of processing for Real_Or_String_Static_Predicate_Matches
+
+   begin
+      --  First deal with special case of inherited predicate, where the
+      --  predicate expression looks like:
+
+      --     Expr and then xxPredicate (typ (Ent))
+
+      --  where Expr is the predicate expression for this level, and the
+      --  right operand is the call to evaluate the inherited predicate.
+
+      if Nkind (Expr) = N_And_Then
+        and then Nkind (Right_Opnd (Expr)) = N_Function_Call
+      then
+         --  OK we have the inherited case, so make a call to evaluate the
+         --  inherited predicate. If that fails, so do we!
+
+         if not
+           Real_Or_String_Static_Predicate_Matches
+             (Val => Val,
+              Typ => Etype (First_Formal (Entity (Name (Right_Opnd (Expr))))))
+         then
+            return False;
+         end if;
+
+         --  Use the left operand for the continued processing
+
+         Copy := Copy_Separate_Tree (Left_Opnd (Expr));
+
+      --  Case where call to predicate function appears on its own
+
+      elsif Nkind (Expr) =  N_Function_Call then
+
+         --  Here the result is just the result of calling the inner predicate
+
+         return
+           Real_Or_String_Static_Predicate_Matches
+             (Val => Val,
+              Typ => Etype (First_Formal (Entity (Name (Expr)))));
+
+      --  If no inherited predicate, copy whole expression
+
+      else
+         Copy := Copy_Separate_Tree (Expr);
+      end if;
+
+      --  Now we replace occurrences of the entity by the value
+
+      Traverse (Copy);
+
+      --  And analyze the resulting static expression to see if it is True
+
+      Analyze_And_Resolve (Copy, Standard_Boolean);
+      return Is_True (Expr_Value (Copy));
+   end Real_Or_String_Static_Predicate_Matches;
+
    -------------------------
    -- Rewrite_In_Raise_CE --
    -------------------------