OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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
This commit is contained in:
Arnaud Charlet 2009-06-19 12:59:04 +02:00
parent e29e248316
commit 93c3fca75e
7 changed files with 343 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/ada/ChangeLog
View File

@ -1,3 +1,21 @@
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

15
gcc/ada/a-nudira.adb
View File

@ -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 --

15
gcc/ada/checks.adb
View File

@ -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)))

14
gcc/ada/einfo.ads
View File

@ -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)

366
gcc/ada/sem_eval.adb
View File

@ -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.
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;
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_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,75 +2699,23 @@ 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;
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;
-- Can only fold if type is scalar (don't fold string ops)
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 for expression being foldable
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if not Fold then
return;
-- 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
Stat := False;
Set_Is_Static_Expression (N, False);
end if;
-- Integer and Enumeration (discrete) type cases
if Is_Discrete_Type (Typ) then
declare
Left_Int : constant Uint := Expr_Value (Left);
Right_Int : constant Uint := Expr_Value (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 others =>
raise Program_Error;
end case;
Fold_Uint (N, Test (Result), Stat);
end;
-- Real type case
else
pragma Assert (Is_Real_Type (Typ));
-- For static real type expressions, we cannot use Compile_Time_Compare
-- since it worries about run-time results which are not exact.
if Stat and then Is_Real_Type (Typ) then
declare
Left_Real : constant Ureal := Expr_Value_R (Left);
Right_Real : constant Ureal := Expr_Value_R (Right);
@ -2683,8 +2733,82 @@ package body Sem_Eval is
raise Program_Error;
end case;
Fold_Uint (N, Test (Result), Stat);
Fold_Uint (N, Test (Result), True);
end;
-- For all other cases, we use Compile_Time_Compare to do the compare
else
declare
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 =>
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 if;
Warn_On_Known_Condition (N);

45
gcc/ada/sem_util.adb
View File

@ -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 --
--------------------

4
gcc/ada/sem_util.ads
View File

@ -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