2009-06-19 Eric Botcazou <ebotcazou@adacore.com>

	* einfo.ads (Handling of Type'Size Values): Fix Object_Size values.

2009-06-19  Robert Dewar  <dewar@adacore.com>

	* a-nudira.adb (Need_64): Handle negative ranges and also dynamic
	ranges

	* checks.adb (Determine_Range): Move the test for generic types later.

	* sem_eval.adb (Compile_Time_Compare): Improve circuitry to catch more
	cases.
	(Eval_Relational_Op): Fold more cases including string compares

	* sem_util.ads, sem_util.adb (References_Generic_Formal_Type): New
	function.



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

1 files changed, 241 insertions, 117 deletions

diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index b659853ae11..19abf4b3672 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -194,6 +194,12 @@ package body Sem_Eval is
    --  call to Check_Non_Static_Context on the operand. If Fold is False on
    --  return, then all processing is complete, and the caller should
    --  return, since there is nothing else to do.
+   --
+   --  If Stat is set True on return, then Is_Static_Expression is also set
+   --  true in node N. There are some cases where this is over-enthusiastic,
+   --  e.g. in the two operand case below, for string comaprison, the result
+   --  is not static even though the two operands are static. In such cases,
+   --  the caller must reset the Is_Static_Expression flag in N.
 
    procedure Test_Expression_Is_Foldable
      (N    : Node_Id;
@@ -393,8 +399,8 @@ package body Sem_Eval is
       Assume_Valid : Boolean;
       Rec          : Boolean := False) return Compare_Result
    is
-      Ltyp : Entity_Id := Etype (L);
-      Rtyp : Entity_Id := Etype (R);
+      Ltyp : Entity_Id := Underlying_Type (Etype (L));
+      Rtyp : Entity_Id := Underlying_Type (Etype (R));
       --  These get reset to the base type for the case of entities where
       --  Is_Known_Valid is not set. This takes care of handling possible
       --  invalid representations using the value of the base type, in
@@ -683,23 +689,46 @@ package body Sem_Eval is
       if L = R then
          return EQ;
 
-      --  If expressions have no types, then do not attempt to determine
-      --  if they are the same, since something funny is going on. One
-      --  case in which this happens is during generic template analysis,
-      --  when bounds are not fully analyzed.
+      --  If expressions have no types, then do not attempt to determine if
+      --  they are the same, since something funny is going on. One case in
+      --  which this happens is during generic template analysis, when bounds
+      --  are not fully analyzed.
 
       elsif No (Ltyp) or else No (Rtyp) then
          return Unknown;
 
-      --  We only attempt compile time analysis for scalar values, and
-      --  not for packed arrays represented as modular types, where the
-      --  semantics of comparison is quite different.
+      --  We do not attempt comparisons for packed arrays arrays represented as
+      --  modular types, where the semantics of comparison is quite different.
 
-      elsif not Is_Scalar_Type (Ltyp)
-        or else Is_Packed_Array_Type (Ltyp)
+      elsif Is_Packed_Array_Type (Ltyp)
+        and then Is_Modular_Integer_Type (Ltyp)
       then
          return Unknown;
 
+      --  For access types, the only time we know the result at compile time
+      --  (apart from identical operands, which we handled already, is if we
+      --  know one operand is null and the other is not, or both operands are
+      --  known null.
+
+      elsif Is_Access_Type (Ltyp) then
+         if Known_Null (L) then
+            if Known_Null (R) then
+               return EQ;
+            elsif Known_Non_Null (R) then
+               return NE;
+            else
+               return Unknown;
+            end if;
+
+         elsif Known_Non_Null (L)
+           and then Known_Null (R)
+         then
+            return NE;
+
+         else
+            return Unknown;
+         end if;
+
       --  Case where comparison involves two compile time known values
 
       elsif Compile_Time_Known_Value (L)
@@ -728,8 +757,42 @@ package body Sem_Eval is
                end if;
             end;
 
-         --  For the integer case we know exactly (note that this includes the
-         --  fixed-point case, where we know the run time integer values now)
+         --  For string types, we have two string literals and we proceed to
+         --  compare them using the Ada style dictionary string comparison.
+
+         elsif not Is_Scalar_Type (Ltyp) then
+            declare
+               Lstring : constant String_Id := Strval (Expr_Value_S (L));
+               Rstring : constant String_Id := Strval (Expr_Value_S (R));
+               Llen    : constant Nat       := String_Length (Lstring);
+               Rlen    : constant Nat       := String_Length (Rstring);
+
+            begin
+               for J in 1 .. Nat'Min (Llen, Rlen) loop
+                  declare
+                     LC : constant Char_Code := Get_String_Char (Lstring, J);
+                     RC : constant Char_Code := Get_String_Char (Rstring, J);
+                  begin
+                     if LC < RC then
+                        return LT;
+                     elsif LC > RC then
+                        return GT;
+                     end if;
+                  end;
+               end loop;
+
+               if Llen < Rlen then
+                  return LT;
+               elsif Llen > Rlen then
+                  return GT;
+               else
+                  return EQ;
+               end if;
+            end;
+
+         --  For remaining scalar cases we know exactly (note that this does
+         --  include the fixed-point case, where we know the run time integer
+         --  values now)
 
          else
             declare
@@ -754,12 +817,36 @@ 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
+         --  Remaining checks apply only for 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;
+
+         --  Defend against generic types, or actually any expressions that
+         --  contain a reference to a generic type from within a generic
+         --  template. We don't want to do any range analysis of such
+         --  expressions for two reasons. First, the bounds of a generic type
+         --  itself are junk and cannot be used for any kind of analysis.
+         --  Second, we may have a case where the range at run time is indeed
+         --  known, but we don't want to do compile time analysis in the
+         --  template based on that range since in an instance the value may be
+         --  static, and able to be elaborated without reference to the bounds
+         --  of types involved. As an example, consider:
+
+         --     (F'Pos (F'Last) + 1) > Integer'Last
+
+         --  The expression on the left side of > is Universal_Integer and thus
+         --  acquires the type Integer for evaluation at run time, and at run
+         --  time it is true that this condition is always False, but within
+         --  an instance F may be a type with a static range greater than the
+         --  range of Integer, and the expression statically evaluates to True.
+
+         if References_Generic_Formal_Type (L)
+              or else
+            References_Generic_Formal_Type (R)
          then
             return Unknown;
          end if;
@@ -770,11 +857,11 @@ package body Sem_Eval is
 
          if not Assume_Valid and then not Assume_No_Invalid_Values then
             if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
-               Ltyp := Base_Type (Ltyp);
+               Ltyp := Underlying_Type (Base_Type (Ltyp));
             end if;
 
             if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then
-               Rtyp := Base_Type (Rtyp);
+               Rtyp := Underlying_Type (Base_Type (Rtyp));
             end if;
          end if;
 
@@ -821,7 +908,7 @@ 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.
 
@@ -829,46 +916,51 @@ package body Sem_Eval is
 
             --  See if we can get a decisive check against one operand and
             --  a bound of the other operand (four possible tests here).
+            --  Note that we avoid testing junk bounds of a generic type.
+
+            if not Is_Generic_Type (Rtyp) then
+               case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
+                                          Discard'Access,
+                                          Assume_Valid, Rec => True)
+               is
+                  when LT => return LT;
+                  when LE => return LE;
+                  when EQ => return LE;
+                  when others => null;
+               end case;
 
-            case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
-                                       Discard'Access,
-                                       Assume_Valid, Rec => True)
-            is
-               when LT => return LT;
-               when LE => return LE;
-               when EQ => return LE;
-               when others => null;
-            end case;
-
-            case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
-                                       Discard'Access,
-                                       Assume_Valid, Rec => True)
-            is
-               when GT => return GT;
-               when GE => return GE;
-               when EQ => return GE;
-               when others => null;
-            end case;
+               case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
+                                          Discard'Access,
+                                          Assume_Valid, Rec => True)
+               is
+                  when GT => return GT;
+                  when GE => return GE;
+                  when EQ => return GE;
+                  when others => null;
+               end case;
+            end if;
 
-            case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
-                                       Discard'Access,
-                                       Assume_Valid, Rec => True)
-            is
-               when GT => return GT;
-               when GE => return GE;
-               when EQ => return GE;
-               when others => null;
-            end case;
+            if not Is_Generic_Type (Ltyp) then
+               case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
+                                          Discard'Access,
+                                          Assume_Valid, Rec => True)
+               is
+                  when GT => return GT;
+                  when GE => return GE;
+                  when EQ => return GE;
+                  when others => null;
+               end case;
 
-            case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
-                                       Discard'Access,
-                                       Assume_Valid, Rec => True)
-            is
-               when LT => return LT;
-               when LE => return LE;
-               when EQ => return LE;
-               when others => null;
-            end case;
+               case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
+                                          Discard'Access,
+                                          Assume_Valid, Rec => True)
+               is
+                  when LT => return LT;
+                  when LE => return LE;
+                  when EQ => return LE;
+                  when others => null;
+               end case;
+            end if;
          end if;
 
          --  Next attempt is to decompose the expressions to extract
@@ -1053,6 +1145,15 @@ package body Sem_Eval is
       Indx := First_Index (T);
       while Present (Indx) loop
          Typ := Underlying_Type (Etype (Indx));
+
+         --  Never look at junk bounds of a generic type
+
+         if Is_Generic_Type (Typ) then
+            return False;
+         end if;
+
+         --  Otherwise check bounds for compile time known
+
          if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
             return False;
          elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
@@ -2395,7 +2496,8 @@ package body Sem_Eval is
    ------------------------
 
    --  Relational operations are static functions, so the result is static
-   --  if both operands are static (RM 4.9(7), 4.9(20)).
+   --  if 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.
 
    procedure Eval_Relational_Op (N : Node_Id) is
       Left   : constant Node_Id   := Left_Opnd (N);
@@ -2597,94 +2699,116 @@ package body Sem_Eval is
          end Length_Mismatch;
       end if;
 
-      --  Another special case: comparisons of access types, where one or both
-      --  operands are known to be null, so the result can be determined.
-
-      if Is_Access_Type (Typ) then
-         if Known_Null (Left) then
-            if Known_Null (Right) then
-               Fold_Uint (N, Test (Nkind (N) = N_Op_Eq), False);
-               Warn_On_Known_Condition (N);
-               return;
-
-            elsif Known_Non_Null (Right) then
-               Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
-               Warn_On_Known_Condition (N);
-               return;
-            end if;
+      --  Test for expression being foldable
 
-         elsif Known_Non_Null (Left) then
-            if Known_Null (Right) then
-               Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
-               Warn_On_Known_Condition (N);
-               return;
-            end if;
-         end if;
-      end if;
+      Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
 
-      --  Can only fold if type is scalar (don't fold string ops)
+      --  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.
 
       if not Is_Scalar_Type (Typ) then
-         Check_Non_Static_Context (Left);
-         Check_Non_Static_Context (Right);
-         return;
-      end if;
-
-      --  If not foldable we are done
-
-      Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
-
-      if not Fold then
-         return;
+         Stat := False;
+         Set_Is_Static_Expression (N, False);
       end if;
 
-      --  Integer and Enumeration (discrete) type cases
+      --  For static real type expressions, we cannot use Compile_Time_Compare
+      --  since it worries about run-time results which are not exact.
 
-      if Is_Discrete_Type (Typ) then
+      if Stat and then Is_Real_Type (Typ) then
          declare
-            Left_Int  : constant Uint := Expr_Value (Left);
-            Right_Int : constant Uint := Expr_Value (Right);
+            Left_Real  : constant Ureal := Expr_Value_R (Left);
+            Right_Real : constant Ureal := Expr_Value_R (Right);
 
          begin
             case Nkind (N) is
-               when N_Op_Eq => Result := Left_Int =  Right_Int;
-               when N_Op_Ne => Result := Left_Int /= Right_Int;
-               when N_Op_Lt => Result := Left_Int <  Right_Int;
-               when N_Op_Le => Result := Left_Int <= Right_Int;
-               when N_Op_Gt => Result := Left_Int >  Right_Int;
-               when N_Op_Ge => Result := Left_Int >= Right_Int;
+               when N_Op_Eq => Result := (Left_Real =  Right_Real);
+               when N_Op_Ne => Result := (Left_Real /= Right_Real);
+               when N_Op_Lt => Result := (Left_Real <  Right_Real);
+               when N_Op_Le => Result := (Left_Real <= Right_Real);
+               when N_Op_Gt => Result := (Left_Real >  Right_Real);
+               when N_Op_Ge => Result := (Left_Real >= Right_Real);
 
                when others =>
                   raise Program_Error;
             end case;
 
-            Fold_Uint (N, Test (Result), Stat);
+            Fold_Uint (N, Test (Result), True);
          end;
 
-      --  Real type case
+      --  For all other cases, we use Compile_Time_Compare to do the compare
 
       else
-         pragma Assert (Is_Real_Type (Typ));
-
          declare
-            Left_Real  : constant Ureal := Expr_Value_R (Left);
-            Right_Real : constant Ureal := Expr_Value_R (Right);
+            CR : constant Compare_Result :=
+                   Compile_Time_Compare (Left, Right, Assume_Valid => False);
 
          begin
+            if CR = Unknown then
+               return;
+            end if;
+
             case Nkind (N) is
-               when N_Op_Eq => Result := (Left_Real =  Right_Real);
-               when N_Op_Ne => Result := (Left_Real /= Right_Real);
-               when N_Op_Lt => Result := (Left_Real <  Right_Real);
-               when N_Op_Le => Result := (Left_Real <= Right_Real);
-               when N_Op_Gt => Result := (Left_Real >  Right_Real);
-               when N_Op_Ge => Result := (Left_Real >= Right_Real);
+               when N_Op_Eq =>
+                  if CR = EQ then
+                     Result := True;
+                  elsif CR = NE or else CR = GT or else CR = LT then
+                     Result := False;
+                  else
+                     return;
+                  end if;
+
+               when N_Op_Ne =>
+                  if CR = NE or else CR = GT or else CR = LT then
+                     Result := True;
+                  elsif CR = EQ then
+                     Result := False;
+                  else
+                     return;
+                  end if;
+
+               when N_Op_Lt =>
+                  if CR = LT then
+                     Result := True;
+                  elsif CR = EQ or else CR = GT or else CR = GE then
+                     Result := False;
+                  else
+                     return;
+                  end if;
+
+               when N_Op_Le =>
+                  if CR = LT or else CR = EQ or else CR = LE then
+                     Result := True;
+                  elsif CR = GT then
+                     Result := False;
+                  else
+                     return;
+                  end if;
+
+               when N_Op_Gt =>
+                  if CR = GT then
+                     Result := True;
+                  elsif CR = EQ or else CR = LT or else CR = LE then
+                     Result := False;
+                  else
+                     return;
+                  end if;
+
+               when N_Op_Ge =>
+                  if CR = GT or else CR = EQ or else CR = GE then
+                     Result := True;
+                  elsif CR = LT then
+                     Result := False;
+                  else
+                     return;
+                  end if;
 
                when others =>
                   raise Program_Error;
             end case;
-
-            Fold_Uint (N, Test (Result), Stat);
          end;
+
+         Fold_Uint (N, Test (Result), Stat);
       end if;
 
       Warn_On_Known_Condition (N);