[multiple changes]

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.

From-SVN: r148697

gcc/ada/ChangeLog

+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.
+
 2009-06-19  Robert Dewar  <dewar@adacore.com>
 
 	* sem_type.ads, sem_ch12.adb: Minor reformatting

gcc/ada/a-nudira.adb

@@ -51,11 +51,24 @@ package body Ada.Numerics.Discrete_Random is
 
    type Pointer is access all State;
 
-   Need_64 : constant Boolean := Rst'Pos (Rst'Last) > Int'Last;
+   Need_64 : constant Boolean := Rst'Pos (Rst'Last) > 2**31 - 1
+                                   or else
+                                 Rst'Pos (Rst'First) < 2**31;
    --  Set if we need more than 32 bits in the result. In practice we will
    --  only use the meaningful 48 bits of any 64 bit number generated, since
    --  if more than 48 bits are required, we split the computation into two
    --  separate parts, since the algorithm does not behave above 48 bits.
+   --
+   --  Note: the right hand side used to be Int'Last, but that won't work
+   --  since it means that if Rst is a dynamic subtype, the comparison is
+   --  evaluated at run time in type Int, which is too small. In practice
+   --  the use of dynamic bounds is rare, and this constant will always
+   --  be evaluated at compile time in an instance.
+   --
+   --  This still is not quite right for dynamic subtypes of 64-bit modular
+   --  types where the upper bound can exceed the upper bound of universal
+   --  integer. Not clear how to do this with a nice static expression ???
+   --  Might have to introduce a special Type'First_In_32_Bits attribute!
 
    -----------------------
    -- Local Subprograms --

gcc/ada/checks.adb

@@ -3065,7 +3065,7 @@ package body Checks is
       function OK_Operands return Boolean;
       --  Used for binary operators. Determines the ranges of the left and
       --  right operands, and if they are both OK, returns True, and puts
-      --  the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
+      --  the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
 
       -----------------
       -- OK_Operands --
@@ -3108,10 +3108,6 @@ package body Checks is
         --  ignore if error posted on the reference node.
 
         or else Error_Posted (N) or else Error_Posted (Typ)
-
-        --  Ignore generic type, since range is indeed bogus
-
-        or else Is_Generic_Type (Typ)
       then
          OK := False;
          return;
@@ -3148,6 +3144,15 @@ package body Checks is
       --  overflow situation, which is a separate check, we are talking here
       --  only about the expression value).
 
+      --  First a check, never try to find the bounds of a generic type, since
+      --  these bounds are always junk values, and it is only valid to look at
+      --  the bounds in an instance.
+
+      if Is_Generic_Type (Typ) then
+         OK := False;
+         return;
+      end if;
+
       --  First step, change to use base type unless we know the value is valid
 
       if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))

gcc/ada/einfo.ads

@@ -214,13 +214,13 @@ package Einfo is
 --     type x1 is range 0..5;                      8               3
 
 --     type x2 is range 0..5;
---     for x2'size use 12;                        12              12
+--     for x2'size use 12;                        16              12
 
---     subtype x3 is x2 range 0 .. 3;             12               2
+--     subtype x3 is x2 range 0 .. 3;             16               2
 
 --     subtype x4 is x2'base range 0 .. 10;        8               4
 
---     subtype x5 is x2 range 0 .. dynamic;       12              (7)
+--     subtype x5 is x2 range 0 .. dynamic;       16              (7)
 
 --     subtype x6 is x2'base range 0 .. dynamic;   8              (7)
 
@@ -2081,9 +2081,9 @@ package Einfo is
 --       (generic function, generic subprogram), False for all other entities.
 
 --    Is_Generic_Type (Flag13)
---       Present in all types and subtypes. Set for types which are generic
---       formal types. Such types have an Ekind that corresponds to their
---       classification, so the Ekind cannot be used to identify generic types.
+--       Present in all entities. Set for types which are generic formal types.
+--       Such types have an Ekind that corresponds to their classification, so
+--       the Ekind cannot be used to identify generic types.
 
 --    Is_Generic_Unit (synthesized)
 --       Applies to all entities. Yields True for a generic unit (generic
@@ -4503,6 +4503,7 @@ package Einfo is
    --    Is_First_Subtype                    (Flag70)
    --    Is_Formal_Subprogram                (Flag111)
    --    Is_Generic_Instance                 (Flag130)
+   --    Is_Generic_Type                     (Flag13)
    --    Is_Hidden                           (Flag57)
    --    Is_Hidden_Open_Scope                (Flag171)
    --    Is_Immediately_Visible              (Flag7)
@@ -4609,7 +4610,6 @@ package Einfo is
    --    Is_Eliminated                       (Flag124)
    --    Is_Frozen                           (Flag4)
    --    Is_Generic_Actual_Type              (Flag94)
-   --    Is_Generic_Type                     (Flag13)
    --    Is_Protected_Interface              (Flag198)
    --    Is_RACW_Stub_Type                   (Flag244)
    --    Is_Synchronized_Interface           (Flag199)

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;
 
@@ -829,7 +916,9 @@ 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)
@@ -849,7 +938,9 @@ package body Sem_Eval is
                   when EQ => return GE;
                   when others => null;
                end case;
+            end if;
 
+            if not Is_Generic_Type (Ltyp) then
                case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
                                           Discard'Access,
                                           Assume_Valid, Rec => True)
@@ -870,6 +961,7 @@ package body Sem_Eval is
                   when others => null;
                end case;
             end if;
+         end if;
 
          --  Next attempt is to decompose the expressions to extract
          --  a constant offset resulting from the use of any of the forms:
@@ -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.
+      --  Test for expression being foldable
 
-      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;
-
-         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;
+         end;
 
          Fold_Uint (N, Test (Result), Stat);
-         end;
       end if;
 
       Warn_On_Known_Condition (N);

gcc/ada/sem_util.adb

@@ -9482,6 +9482,51 @@ package body Sem_Util is
       return Token_Node;
    end Real_Convert;
 
+   ------------------------------------
+   -- References_Generic_Formal_Type --
+   ------------------------------------
+
+   function References_Generic_Formal_Type (N : Node_Id) return Boolean is
+
+      function Process (N : Node_Id) return Traverse_Result;
+      --  Process one node in search for generic formal type
+
+      -------------
+      -- Process --
+      -------------
+
+      function Process (N : Node_Id) return Traverse_Result is
+      begin
+         if Nkind (N) in N_Has_Entity then
+            declare
+               E : constant Entity_Id := Entity (N);
+            begin
+               if Present (E) then
+                  if Is_Generic_Type (E) then
+                     return Abandon;
+                  elsif Present (Etype (E))
+                    and then Is_Generic_Type (Etype (E))
+                  then
+                     return Abandon;
+                  end if;
+               end if;
+            end;
+         end if;
+
+         return Atree.OK;
+      end Process;
+
+      function Traverse is new Traverse_Func (Process);
+      --  Traverse tree to look for generic type
+
+   begin
+      if Inside_A_Generic then
+         return Traverse (N) = Abandon;
+      else
+         return False;
+      end if;
+   end References_Generic_Formal_Type;
+
    --------------------
    -- Remove_Homonym --
    --------------------

gcc/ada/sem_util.ads

@@ -1026,6 +1026,10 @@ package Sem_Util is
    --  S is a possibly signed syntactically valid real literal. The result
    --  returned is an N_Real_Literal node representing the literal value.
 
+   function References_Generic_Formal_Type (N : Node_Id) return Boolean;
+   --  Returns True if the expression Expr contains any references to a
+   --  generic type. This can only happen within a generic template.
+
    procedure Remove_Homonym (E : Entity_Id);
    --  Removes E from the homonym chain