-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
------------------------
procedure Rewrite_Comparison (N : Node_Id) is
- Warning_Generated : Boolean := False;
- -- Set to True if first pass with Assume_Valid generates a warning in
- -- which case we skip the second pass to avoid warning overloaded.
+ Typ : constant Entity_Id := Etype (N);
- Result : Node_Id;
- -- Set to Standard_True or Standard_False
+ False_Result : Boolean;
+ True_Result : Boolean;
begin
if Nkind (N) = N_Type_Conversion then
return;
end if;
- -- Now start looking at the comparison in detail. We potentially go
- -- through this loop twice. The first time, Assume_Valid is set False
- -- in the call to Compile_Time_Compare. If this call results in a
- -- clear result of always True or Always False, that's decisive and
- -- we are done. Otherwise we repeat the processing with Assume_Valid
- -- set to True to generate additional warnings. We can skip that step
- -- if Constant_Condition_Warnings is False.
+ -- Determine the potential outcome of the comparison assuming that the
+ -- operands are valid and emit a warning when the comparison evaluates
+ -- to True or False only in the presence of invalid values.
- for AV in False .. True loop
- declare
- Typ : constant Entity_Id := Etype (N);
- Op1 : constant Node_Id := Left_Opnd (N);
- Op2 : constant Node_Id := Right_Opnd (N);
+ Warn_On_Constant_Valid_Condition (N);
- Res : constant Compare_Result :=
- Compile_Time_Compare (Op1, Op2, Assume_Valid => AV);
- -- Res indicates if compare outcome can be compile time determined
+ -- Determine the potential outcome of the comparison assuming that the
+ -- operands are not valid.
- True_Result : Boolean;
- False_Result : Boolean;
-
- begin
- case N_Op_Compare (Nkind (N)) is
- when N_Op_Eq =>
- True_Result := Res = EQ;
- False_Result := Res = LT or else Res = GT or else Res = NE;
-
- when N_Op_Ge =>
- True_Result := Res in Compare_GE;
- False_Result := Res = LT;
-
- if Res = LE
- and then Constant_Condition_Warnings
- and then Comes_From_Source (Original_Node (N))
- and then Nkind (Original_Node (N)) = N_Op_Ge
- and then not In_Instance
- and then Is_Integer_Type (Etype (Left_Opnd (N)))
- and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
- then
- Error_Msg_N
- ("can never be greater than, could replace by "
- & """'=""?c?", N);
- Warning_Generated := True;
- end if;
-
- when N_Op_Gt =>
- True_Result := Res = GT;
- False_Result := Res in Compare_LE;
-
- when N_Op_Lt =>
- True_Result := Res = LT;
- False_Result := Res in Compare_GE;
-
- when N_Op_Le =>
- True_Result := Res in Compare_LE;
- False_Result := Res = GT;
-
- if Res = GE
- and then Constant_Condition_Warnings
- and then Comes_From_Source (Original_Node (N))
- and then Nkind (Original_Node (N)) = N_Op_Le
- and then not In_Instance
- and then Is_Integer_Type (Etype (Left_Opnd (N)))
- and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
- then
- Error_Msg_N
- ("can never be less than, could replace by ""'=""?c?",
- N);
- Warning_Generated := True;
- end if;
-
- when N_Op_Ne =>
- True_Result := Res = NE or else Res = GT or else Res = LT;
- False_Result := Res = EQ;
- end case;
-
- -- If this is the first iteration, then we actually convert the
- -- comparison into True or False, if the result is certain.
-
- if AV = False then
- if True_Result or False_Result then
- Result := Boolean_Literals (True_Result);
- Rewrite (N,
- Convert_To (Typ,
- New_Occurrence_Of (Result, Sloc (N))));
- Analyze_And_Resolve (N, Typ);
- Warn_On_Known_Condition (N);
- return;
- end if;
+ Test_Comparison
+ (Op => N,
+ Assume_Valid => False,
+ True_Result => True_Result,
+ False_Result => False_Result);
- -- If this is the second iteration (AV = True), and the original
- -- node comes from source and we are not in an instance, then give
- -- a warning if we know result would be True or False. Note: we
- -- know Constant_Condition_Warnings is set if we get here.
+ -- The outcome is a decisive False or True, rewrite the operator
- elsif Comes_From_Source (Original_Node (N))
- and then not In_Instance
- then
- if True_Result then
- Error_Msg_N
- ("condition can only be False if invalid values present??",
- N);
- elsif False_Result then
- Error_Msg_N
- ("condition can only be True if invalid values present??",
- N);
- end if;
- end if;
- end;
-
- -- Skip second iteration if not warning on constant conditions or
- -- if the first iteration already generated a warning of some kind or
- -- if we are in any case assuming all values are valid (so that the
- -- first iteration took care of the valid case).
+ if False_Result or True_Result then
+ Rewrite (N,
+ Convert_To (Typ,
+ New_Occurrence_Of (Boolean_Literals (True_Result), Sloc (N))));
- exit when not Constant_Condition_Warnings;
- exit when Warning_Generated;
- exit when Assume_No_Invalid_Values;
- end loop;
+ Analyze_And_Resolve (N, Typ);
+ Warn_On_Known_Condition (N);
+ end if;
end Rewrite_Comparison;
----------------------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- equality test A = "ABC", and the former is definitely static.
procedure Eval_Relational_Op (N : Node_Id) is
- Left : constant Node_Id := Left_Opnd (N);
- Right : constant Node_Id := Right_Opnd (N);
- Typ : constant Entity_Id := Etype (Left);
- Otype : Entity_Id := Empty;
- Result : Boolean;
+ Left : constant Node_Id := Left_Opnd (N);
+ Right : constant Node_Id := Right_Opnd (N);
- begin
- -- One special case to deal with first. If we can tell that the result
- -- will be false because the lengths of one or more index subtypes are
- -- compile time known and different, then we can replace the entire
- -- result by False. We only do this for one dimensional arrays, because
- -- the case of multi-dimensional arrays is rare and too much trouble. If
- -- one of the operands is an illegal aggregate, its type might still be
- -- an arbitrary composite type, so nothing to do.
+ procedure Decompose_Expr
+ (Expr : Node_Id;
+ Ent : out Entity_Id;
+ Kind : out Character;
+ Cons : out Uint;
+ Orig : Boolean := True);
+ -- Given expression Expr, see if it is of the form X [+/- K]. If so, Ent
+ -- is set to the entity in X, Kind is 'F','L','E' for 'First or 'Last or
+ -- simple entity, and Cons is the value of K. If the expression is not
+ -- of the required form, Ent is set to Empty.
+ --
+ -- Orig indicates whether Expr is the original expression to consider,
+ -- or if we are handling a sub-expression (e.g. recursive call to
+ -- Decompose_Expr).
+
+ procedure Fold_General_Op (Is_Static : Boolean);
+ -- Attempt to fold arbitrary relational operator N. Flag Is_Static must
+ -- be set when the operator denotes a static expression.
+
+ procedure Fold_Static_Real_Op;
+ -- Attempt to fold static real type relational operator N
+
+ function Static_Length (Expr : Node_Id) return Uint;
+ -- If Expr is an expression for a constrained array whose length is
+ -- known at compile time, return the non-negative length, otherwise
+ -- return -1.
+
+ --------------------
+ -- Decompose_Expr --
+ --------------------
+
+ procedure Decompose_Expr
+ (Expr : Node_Id;
+ Ent : out Entity_Id;
+ Kind : out Character;
+ Cons : out Uint;
+ Orig : Boolean := True)
+ is
+ Exp : Node_Id;
- if Is_Array_Type (Typ)
- and then Typ /= Any_Composite
- and then Number_Dimensions (Typ) = 1
- and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
- then
- if Raises_Constraint_Error (Left)
- or else
- Raises_Constraint_Error (Right)
+ begin
+ -- Assume that the expression does not meet the expected form
+
+ Cons := No_Uint;
+ Ent := Empty;
+ Kind := '?';
+
+ if Nkind (Expr) = N_Op_Add
+ and then Compile_Time_Known_Value (Right_Opnd (Expr))
then
- return;
+ Exp := Left_Opnd (Expr);
+ Cons := Expr_Value (Right_Opnd (Expr));
+
+ elsif Nkind (Expr) = N_Op_Subtract
+ and then Compile_Time_Known_Value (Right_Opnd (Expr))
+ then
+ Exp := Left_Opnd (Expr);
+ Cons := -Expr_Value (Right_Opnd (Expr));
+
+ -- If the bound is a constant created to remove side effects, recover
+ -- the original expression to see if it has one of the recognizable
+ -- forms.
+
+ elsif Nkind (Expr) = N_Identifier
+ and then not Comes_From_Source (Entity (Expr))
+ and then Ekind (Entity (Expr)) = E_Constant
+ and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
+ then
+ Exp := Expression (Parent (Entity (Expr)));
+ Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False);
+
+ -- If original expression includes an entity, create a reference
+ -- to it for use below.
+
+ if Present (Ent) then
+ Exp := New_Occurrence_Of (Ent, Sloc (Ent));
+ else
+ return;
+ end if;
+
+ else
+ -- Only consider the case of X + 0 for a full expression, and
+ -- not when recursing, otherwise we may end up with evaluating
+ -- expressions not known at compile time to 0.
+
+ if Orig then
+ Exp := Expr;
+ Cons := Uint_0;
+ else
+ return;
+ end if;
end if;
- -- OK, we have the case where we may be able to do this fold
+ -- At this stage Exp is set to the potential X
- Length_Mismatch : declare
- procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
- -- If Op is an expression for a constrained array with a known at
- -- compile time length, then Len is set to this (non-negative
- -- length). Otherwise Len is set to minus 1.
+ if Nkind (Exp) = N_Attribute_Reference then
+ if Attribute_Name (Exp) = Name_First then
+ Kind := 'F';
+ elsif Attribute_Name (Exp) = Name_Last then
+ Kind := 'L';
+ else
+ return;
+ end if;
- -----------------------
- -- Get_Static_Length --
- -----------------------
+ Exp := Prefix (Exp);
- procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
- T : Entity_Id;
+ else
+ Kind := 'E';
+ end if;
- begin
- -- First easy case string literal
+ if Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
+ Ent := Entity (Exp);
+ end if;
+ end Decompose_Expr;
+
+ ---------------------
+ -- Fold_General_Op --
+ ---------------------
+
+ procedure Fold_General_Op (Is_Static : Boolean) is
+ CR : constant Compare_Result :=
+ Compile_Time_Compare (Left, Right, Assume_Valid => False);
- if Nkind (Op) = N_String_Literal then
- Len := UI_From_Int (String_Length (Strval (Op)));
+ Result : Boolean;
+
+ 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;
- -- Second easy case, not constrained subtype, so no length
-
- if not Is_Constrained (Etype (Op)) then
- Len := Uint_Minus_1;
+ 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;
- -- General case
+ 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;
- T := Etype (First_Index (Etype (Op)));
+ 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;
- -- The simple case, both bounds are known at compile time
+ 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;
- if Is_Discrete_Type (T)
- and then Compile_Time_Known_Value (Type_Low_Bound (T))
- and then Compile_Time_Known_Value (Type_High_Bound (T))
- then
- Len := UI_Max (Uint_0,
- Expr_Value (Type_High_Bound (T)) -
- Expr_Value (Type_Low_Bound (T)) + 1);
+ 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;
- -- A more complex case, where the bounds are of the form
- -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
- -- either A'First or A'Last (with A an entity name), or X is an
- -- entity name, and the two X's are the same and K1 and K2 are
- -- known at compile time, in this case, the length can also be
- -- computed at compile time, even though the bounds are not
- -- known. A common case of this is e.g. (X'First .. X'First+5).
-
- Extract_Length : declare
- procedure Decompose_Expr
- (Expr : Node_Id;
- Ent : out Entity_Id;
- Kind : out Character;
- Cons : out Uint;
- Orig : Boolean := True);
- -- Given an expression see if it is of the form given above,
- -- X [+/- K]. If so Ent is set to the entity in X, Kind is
- -- 'F','L','E' for 'First/'Last/simple entity, and Cons is
- -- the value of K. If the expression is not of the required
- -- form, Ent is set to Empty.
- --
- -- Orig indicates whether Expr is the original expression
- -- to consider, or if we are handling a sub-expression
- -- (e.g. recursive call to Decompose_Expr).
-
- --------------------
- -- Decompose_Expr --
- --------------------
-
- procedure Decompose_Expr
- (Expr : Node_Id;
- Ent : out Entity_Id;
- Kind : out Character;
- Cons : out Uint;
- Orig : Boolean := True)
- is
- Exp : Node_Id;
+ when others =>
+ raise Program_Error;
+ end case;
- begin
- Ent := Empty;
+ -- Determine the potential outcome of the relation assuming the
+ -- operands are valid and emit a warning when the relation yields
+ -- True or False only in the presence of invalid values.
- -- Ignored values:
+ Warn_On_Constant_Valid_Condition (N);
- Kind := '?';
- Cons := No_Uint;
+ Fold_Uint (N, Test (Result), Is_Static);
+ end Fold_General_Op;
- if Nkind (Expr) = N_Op_Add
- and then Compile_Time_Known_Value (Right_Opnd (Expr))
- then
- Exp := Left_Opnd (Expr);
- Cons := Expr_Value (Right_Opnd (Expr));
+ -------------------------
+ -- Fold_Static_Real_Op --
+ -------------------------
- elsif Nkind (Expr) = N_Op_Subtract
- and then Compile_Time_Known_Value (Right_Opnd (Expr))
- then
- Exp := Left_Opnd (Expr);
- Cons := -Expr_Value (Right_Opnd (Expr));
+ procedure Fold_Static_Real_Op is
+ Left_Real : constant Ureal := Expr_Value_R (Left);
+ Right_Real : constant Ureal := Expr_Value_R (Right);
+ Result : Boolean;
- -- If the bound is a constant created to remove side
- -- effects, recover original expression to see if it has
- -- one of the recognizable forms.
+ begin
+ case Nkind (N) is
+ when N_Op_Eq => Result := (Left_Real = Right_Real);
+ when N_Op_Ge => Result := (Left_Real >= Right_Real);
+ when N_Op_Gt => Result := (Left_Real > Right_Real);
+ when N_Op_Le => Result := (Left_Real <= Right_Real);
+ when N_Op_Lt => Result := (Left_Real < Right_Real);
+ when N_Op_Ne => Result := (Left_Real /= Right_Real);
+ when others => raise Program_Error;
+ end case;
+
+ Fold_Uint (N, Test (Result), True);
+ end Fold_Static_Real_Op;
- elsif Nkind (Expr) = N_Identifier
- and then not Comes_From_Source (Entity (Expr))
- and then Ekind (Entity (Expr)) = E_Constant
- and then
- Nkind (Parent (Entity (Expr))) = N_Object_Declaration
- then
- Exp := Expression (Parent (Entity (Expr)));
- Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False);
+ -------------------
+ -- Static_Length --
+ -------------------
- -- If original expression includes an entity, create a
- -- reference to it for use below.
+ function Static_Length (Expr : Node_Id) return Uint is
+ Cons1 : Uint;
+ Cons2 : Uint;
+ Ent1 : Entity_Id;
+ Ent2 : Entity_Id;
+ Kind1 : Character;
+ Kind2 : Character;
+ Typ : Entity_Id;
- if Present (Ent) then
- Exp := New_Occurrence_Of (Ent, Sloc (Ent));
- else
- return;
- end if;
+ begin
+ -- First easy case string literal
- else
- -- Only consider the case of X + 0 for a full
- -- expression, and not when recursing, otherwise we
- -- may end up with evaluating expressions not known
- -- at compile time to 0.
-
- if Orig then
- Exp := Expr;
- Cons := Uint_0;
- else
- return;
- end if;
- end if;
+ if Nkind (Expr) = N_String_Literal then
+ return UI_From_Int (String_Length (Strval (Expr)));
- -- At this stage Exp is set to the potential X
+ -- Second easy case, not constrained subtype, so no length
- if Nkind (Exp) = N_Attribute_Reference then
- if Attribute_Name (Exp) = Name_First then
- Kind := 'F';
- elsif Attribute_Name (Exp) = Name_Last then
- Kind := 'L';
- else
- return;
- end if;
+ elsif not Is_Constrained (Etype (Expr)) then
+ return Uint_Minus_1;
+ end if;
- Exp := Prefix (Exp);
+ -- General case
- else
- Kind := 'E';
- end if;
+ Typ := Etype (First_Index (Etype (Expr)));
- if Is_Entity_Name (Exp)
- and then Present (Entity (Exp))
- then
- Ent := Entity (Exp);
- end if;
- end Decompose_Expr;
+ -- The simple case, both bounds are known at compile time
- -- Local Variables
+ if Is_Discrete_Type (Typ)
+ and then Compile_Time_Known_Value (Type_Low_Bound (Typ))
+ and then Compile_Time_Known_Value (Type_High_Bound (Typ))
+ then
+ return
+ UI_Max (Uint_0, Expr_Value (Type_High_Bound (Typ)) -
+ Expr_Value (Type_Low_Bound (Typ)) + 1);
+ end if;
- Ent1, Ent2 : Entity_Id;
- Kind1, Kind2 : Character;
- Cons1, Cons2 : Uint;
+ -- A more complex case, where the bounds are of the form X [+/- K1]
+ -- .. X [+/- K2]), where X is an expression that is either A'First or
+ -- A'Last (with A an entity name), or X is an entity name, and the
+ -- two X's are the same and K1 and K2 are known at compile time, in
+ -- this case, the length can also be computed at compile time, even
+ -- though the bounds are not known. A common case of this is e.g.
+ -- (X'First .. X'First+5).
+
+ Decompose_Expr
+ (Original_Node (Type_Low_Bound (Typ)), Ent1, Kind1, Cons1);
+ Decompose_Expr
+ (Original_Node (Type_High_Bound (Typ)), Ent2, Kind2, Cons2);
+
+ if Present (Ent1) and then Ent1 = Ent2 and then Kind1 = Kind2 then
+ return Cons2 - Cons1 + 1;
+ else
+ return Uint_Minus_1;
+ end if;
+ end Static_Length;
- -- Start of processing for Extract_Length
+ -- Local variables
- begin
- Decompose_Expr
- (Original_Node (Type_Low_Bound (T)), Ent1, Kind1, Cons1);
- Decompose_Expr
- (Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2);
-
- if Present (Ent1)
- and then Ent1 = Ent2
- and then Kind1 = Kind2
- then
- Len := Cons2 - Cons1 + 1;
- else
- Len := Uint_Minus_1;
- end if;
- end Extract_Length;
- end Get_Static_Length;
+ Left_Typ : constant Entity_Id := Etype (Left);
+ Right_Typ : constant Entity_Id := Etype (Right);
+ Fold : Boolean;
+ Left_Len : Uint;
+ Op_Typ : Entity_Id := Empty;
+ Right_Len : Uint;
+
+ Is_Static_Expression : Boolean;
- -- Local Variables
+ -- Start of processing for Eval_Relational_Op
+
+ begin
+ -- One special case to deal with first. If we can tell that the result
+ -- will be false because the lengths of one or more index subtypes are
+ -- compile time known and different, then we can replace the entire
+ -- result by False. We only do this for one dimensional arrays, because
+ -- the case of multi-dimensional arrays is rare and too much trouble. If
+ -- one of the operands is an illegal aggregate, its type might still be
+ -- an arbitrary composite type, so nothing to do.
- Len_L : Uint;
- Len_R : Uint;
+ if Is_Array_Type (Left_Typ)
+ and then Left_Typ /= Any_Composite
+ and then Number_Dimensions (Left_Typ) = 1
+ and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
+ then
+ if Raises_Constraint_Error (Left)
+ or else
+ Raises_Constraint_Error (Right)
+ then
+ return;
- -- Start of processing for Length_Mismatch
+ -- OK, we have the case where we may be able to do this fold
- begin
- Get_Static_Length (Left, Len_L);
- Get_Static_Length (Right, Len_R);
+ else
+ Left_Len := Static_Length (Left);
+ Right_Len := Static_Length (Right);
- if Len_L /= Uint_Minus_1
- and then Len_R /= Uint_Minus_1
- and then Len_L /= Len_R
+ if Left_Len /= Uint_Minus_1
+ and then Right_Len /= Uint_Minus_1
+ and then Left_Len /= Right_Len
then
Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
Warn_On_Known_Condition (N);
return;
end if;
- end Length_Mismatch;
- end if;
-
- declare
- Is_Static_Expression : Boolean;
+ end if;
- Is_Foldable : Boolean;
- pragma Unreferenced (Is_Foldable);
+ -- General case
- begin
- -- Initialize the value of Is_Static_Expression. The value of
- -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed
- -- since, even when some operand is a variable, we can still perform
- -- the static evaluation of the expression in some cases (for
- -- example, for a variable of a subtype of Integer we statically
- -- know that any value stored in such variable is smaller than
- -- Integer'Last).
+ else
+ -- Initialize the value of Is_Static_Expression. The value of Fold
+ -- returned by Test_Expression_Is_Foldable is not needed since, even
+ -- when some operand is a variable, we can still perform the static
+ -- evaluation of the expression in some cases (for example, for a
+ -- variable of a subtype of Integer we statically know that any value
+ -- stored in such variable is smaller than Integer'Last).
Test_Expression_Is_Foldable
- (N, Left, Right, Is_Static_Expression, Is_Foldable);
+ (N, Left, Right, Is_Static_Expression, Fold);
- -- 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, except that
- -- as noted above, we allow equality/inequality for strings.
+ -- Only comparisons of scalars can give static results. A comparison
+ -- of strings never yields a static result, even if both operands are
+ -- static strings, except that as noted above, we allow equality and
+ -- inequality for strings.
- if Is_String_Type (Typ)
+ if Is_String_Type (Left_Typ)
and then not Comes_From_Source (N)
and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
then
null;
- elsif not Is_Scalar_Type (Typ) then
+ elsif not Is_Scalar_Type (Left_Typ) then
Is_Static_Expression := False;
Set_Is_Static_Expression (N, False);
end if;
-- an explicit scope, determine appropriate specific numeric type,
-- and diagnose possible ambiguity.
- if Is_Universal_Numeric_Type (Etype (Left))
+ if Is_Universal_Numeric_Type (Left_Typ)
and then
- Is_Universal_Numeric_Type (Etype (Right))
+ Is_Universal_Numeric_Type (Right_Typ)
then
- Otype := Find_Universal_Operator_Type (N);
+ Op_Typ := Find_Universal_Operator_Type (N);
end if;
- -- For static real type expressions, do not use Compile_Time_Compare
- -- since it worries about run-time results which are not exact.
-
- if Is_Static_Expression and then Is_Real_Type (Typ) then
- declare
- 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_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), True);
- end;
-
- -- For all other cases, we use Compile_Time_Compare to do the compare
+ -- Attempt to fold the relational operator
+ if Is_Static_Expression and then Is_Real_Type (Left_Typ) then
+ Fold_Static_Real_Op;
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), Is_Static_Expression);
+ Fold_General_Op (Is_Static_Expression);
end if;
- end;
+ end if;
-- For the case of a folded relational operator on a specific numeric
- -- type, freeze operand type now.
+ -- type, freeze the operand type now.
- if Present (Otype) then
- Freeze_Before (N, Otype);
+ if Present (Op_Typ) then
+ Freeze_Before (N, Op_Typ);
end if;
Warn_On_Known_Condition (N);
end if;
end Test;
+ ---------------------
+ -- Test_Comparison --
+ ---------------------
+
+ procedure Test_Comparison
+ (Op : Node_Id;
+ Assume_Valid : Boolean;
+ True_Result : out Boolean;
+ False_Result : out Boolean)
+ is
+ Left : constant Node_Id := Left_Opnd (Op);
+ Left_Typ : constant Entity_Id := Etype (Left);
+ Orig_Op : constant Node_Id := Original_Node (Op);
+
+ procedure Replacement_Warning (Msg : String);
+ -- Emit a warning on a comparison which can be replaced by '='
+
+ -------------------------
+ -- Replacement_Warning --
+ -------------------------
+
+ procedure Replacement_Warning (Msg : String) is
+ begin
+ if Constant_Condition_Warnings
+ and then Comes_From_Source (Orig_Op)
+ and then Is_Integer_Type (Left_Typ)
+ and then not Error_Posted (Op)
+ and then not Has_Warnings_Off (Left_Typ)
+ and then not In_Instance
+ then
+ Error_Msg_N (Msg, Op);
+ end if;
+ end Replacement_Warning;
+
+ -- Local variables
+
+ Res : constant Compare_Result :=
+ Compile_Time_Compare (Left, Right_Opnd (Op), Assume_Valid);
+
+ -- Start of processing for Test_Comparison
+
+ begin
+ case N_Op_Compare (Nkind (Op)) is
+ when N_Op_Eq =>
+ True_Result := Res = EQ;
+ False_Result := Res = LT or else Res = GT or else Res = NE;
+
+ when N_Op_Ge =>
+ True_Result := Res in Compare_GE;
+ False_Result := Res = LT;
+
+ if Res = LE and then Nkind (Orig_Op) = N_Op_Ge then
+ Replacement_Warning
+ ("can never be greater than, could replace by ""'=""?c?");
+ end if;
+
+ when N_Op_Gt =>
+ True_Result := Res = GT;
+ False_Result := Res in Compare_LE;
+
+ when N_Op_Le =>
+ True_Result := Res in Compare_LE;
+ False_Result := Res = GT;
+
+ if Res = GE and then Nkind (Orig_Op) = N_Op_Le then
+ Replacement_Warning
+ ("can never be less than, could replace by ""'=""?c?");
+ end if;
+
+ when N_Op_Lt =>
+ True_Result := Res = LT;
+ False_Result := Res in Compare_GE;
+
+ when N_Op_Ne =>
+ True_Result := Res = NE or else Res = GT or else Res = LT;
+ False_Result := Res = EQ;
+ end case;
+ end Test_Comparison;
+
---------------------------------
-- Test_Expression_Is_Foldable --
---------------------------------
projects / thirdparty / gcc.git / commitdiff
