-- --
-- 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- --
-- 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;
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
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)
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
-- 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;
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;
-- 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.
-- 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
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
------------------------
-- 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);
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);
projects / thirdparty / gcc.git / commitdiff
