2006-10-31 Robert Dewar <dewar@adacore.com>

	* sem_eval.adb (Compile_Time_Compare): Make use of information from
	Current_Value in the conditional case, to evaluate additional
	comparisons at compile time.



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

1 files changed, 138 insertions, 12 deletions

diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 65005de952b..84f67a2e284 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -702,6 +702,16 @@ package body Sem_Eval is
       --  Cases where at least one operand is not known at compile time
 
       else
+         --  Remaining checks apply only for non-generic discrete types
+
+         if not Is_Discrete_Type (Ltyp)
+           or else not Is_Discrete_Type (Rtyp)
+           or else Is_Generic_Type (Ltyp)
+           or else Is_Generic_Type (Rtyp)
+         then
+            return Unknown;
+         end if;
+
          --  Here is where we check for comparisons against maximum bounds of
          --  types, where we know that no value can be outside the bounds of
          --  the subtype. Note that this routine is allowed to assume that all
@@ -712,16 +722,12 @@ package body Sem_Eval is
          --  attempt this optimization with generic types, since the type
          --  bounds may not be meaningful in this case.
 
-         --  We are in danger of an infinite recursion here. It does not seem
+         --  We are in danger of an  infinite recursion here. It does not seem
          --  useful to go more than one level deep, so the parameter Rec is
          --  used to protect ourselves against this infinite recursion.
 
-         if not Rec
-           and then Is_Discrete_Type (Ltyp)
-           and then Is_Discrete_Type (Rtyp)
-           and then not Is_Generic_Type (Ltyp)
-           and then not Is_Generic_Type (Rtyp)
-         then
+         if not Rec then
+
             --  See if we can get a decisive check against one operand and
             --  a bound of the other operand (four possible tests here).
 
@@ -785,13 +791,134 @@ package body Sem_Eval is
                else
                   return GT;
                end if;
+            end if;
+         end;
+
+         --  Next attempt is to see if we have an entity compared with a
+         --  compile time known value, where there is a current value
+         --  conditional for the entity which can tell us the result.
+
+         declare
+            Var : Node_Id;
+            --  Entity variable (left operand)
+
+            Val : Uint;
+            --  Value (right operand)
+
+            Inv : Boolean;
+            --  If False, we have reversed the operands
+
+            Op : Node_Kind;
+            --  Comparison operator kind from Get_Current_Value_Condition call
 
-            --  If the expressions are different, we cannot say at compile
-            --  time how they compare, so we return the Unknown indication.
+            Opn : Node_Id;
+            --  Value from Get_Current_Value_Condition call
+
+            Opv : Uint;
+            --  Value of Opn
+
+            Result : Compare_Result;
+            --  Known result before inversion
+
+         begin
+            if Is_Entity_Name (L)
+              and then Compile_Time_Known_Value (R)
+            then
+               Var := L;
+               Val := Expr_Value (R);
+               Inv := False;
+
+            elsif Is_Entity_Name (R)
+              and then Compile_Time_Known_Value (L)
+            then
+               Var := R;
+               Val := Expr_Value (L);
+               Inv := True;
+
+               --  That was the last chance at finding a compile time result
 
             else
                return Unknown;
             end if;
+
+            Get_Current_Value_Condition (Var, Op, Opn);
+
+            --  That was the last chance, so if we got nothing return
+
+            if No (Opn) then
+               return Unknown;
+            end if;
+
+            Opv := Expr_Value (Opn);
+
+            --  We got a comparison, so we might have something interesting
+
+            --  Convert LE to LT and GE to GT, just so we have fewer cases
+
+            if Op = N_Op_Le then
+               Op := N_Op_Lt;
+               Opv := Opv + 1;
+            elsif Op = N_Op_Ge then
+               Op := N_Op_Gt;
+               Opv := Opv - 1;
+            end if;
+
+            --  Deal with equality case
+
+            if Op = N_Op_Eq then
+               if Val = Opv then
+                  Result := EQ;
+               elsif Opv < Val then
+                  Result := LT;
+               else
+                  Result := GT;
+               end if;
+
+            --  Deal with inequality case
+
+            elsif Op = N_Op_Ne then
+               if Val = Opv then
+                  Result := NE;
+               else
+                  return Unknown;
+               end if;
+
+            --  Deal with greater than case
+
+            elsif Op = N_Op_Gt then
+               if Opv >= Val then
+                  Result := GT;
+               elsif Opv = Val - 1 then
+                  Result := GE;
+               else
+                  return Unknown;
+               end if;
+
+            --  Deal with less than case
+
+            else pragma Assert (Op = N_Op_Lt);
+               if Opv <= Val then
+                  Result := LT;
+               elsif Opv = Val + 1 then
+                  Result := LE;
+               else
+                  return Unknown;
+               end if;
+            end if;
+
+            --  Deal with inverting result
+
+            if Inv then
+               case Result is
+                  when GT     => return LT;
+                  when GE     => return LE;
+                  when LT     => return GT;
+                  when LE     => return GE;
+                  when others => return Result;
+               end case;
+            end if;
+
+            return Result;
          end;
       end if;
    end Compile_Time_Compare;
@@ -1235,6 +1362,7 @@ package body Sem_Eval is
    --  with static arguments, or calls to functions that rename a literal.
    --  Only the latter case is handled here, predefined operators are
    --  constant-folded elsewhere.
+
    --  If the function is itself inherited (see 7423-001) the literal of
    --  the parent type must be explicitly converted to the return type
    --  of the function.
@@ -1252,7 +1380,6 @@ package body Sem_Eval is
         and then Is_Enumeration_Type (Base_Type (Typ))
       then
          Lit := Alias (Entity (Name (N)));
-
          while Present (Alias (Lit)) loop
             Lit := Alias (Lit);
          end loop;
@@ -2421,7 +2548,6 @@ package body Sem_Eval is
 
    procedure Eval_Slice (N : Node_Id) is
       Drange : constant Node_Id := Discrete_Range (N);
-
    begin
       if Nkind (Drange) = N_Range then
          Check_Non_Static_Context (Low_Bound (Drange));
@@ -4358,7 +4484,7 @@ package body Sem_Eval is
                   "('R'M 4.9(5))!", N, E);
             end if;
 
-         when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In =>
+         when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test =>
             if Nkind (N) in N_Op_Shift then
                Error_Msg_N
                 ("shift functions are never static ('R'M 4.9(6,18))!", N);