===================================================================
@@ -140,6 +140,10 @@
procedure Expand_Short_Circuit_Operator (N : Node_Id);
-- Common expansion processing for short-circuit boolean operators
+ procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id);
+ -- Deal with comparison in Minimize/Eliminate overflow mode. This is where
+ -- we allow comparison of "out of range" values.
+
function Expand_Composite_Equality
(Nod : Node_Id;
Typ : Entity_Id;
@@ -2276,6 +2280,237 @@
end;
end Expand_Boolean_Operator;
+ ------------------------------------------------
+ -- Expand_Compare_Minimize_Eliminate_Overflow --
+ ------------------------------------------------
+
+ procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Llo, Lhi : Uint;
+ Rlo, Rhi : Uint;
+
+ LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
+ -- Entity for Long_Long_Integer'Base
+
+ Check : constant Overflow_Check_Type := Overflow_Check_Mode (Empty);
+ -- Current checking mode
+
+ procedure Set_True;
+ procedure Set_False;
+ -- These procedures rewrite N with an occurrence of Standard_True or
+ -- Standard_False, and then makes a call to Warn_On_Known_Condition.
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False is
+ begin
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+ Warn_On_Known_Condition (N);
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True is
+ begin
+ Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+ Warn_On_Known_Condition (N);
+ end Set_True;
+
+ -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
+
+ begin
+ -- Nothing to do unless we have a comparison operator with operands
+ -- that are signed integer types, and we are operating in either
+ -- MINIMIZED or ELIMINATED overflow checking mode.
+
+ if Nkind (N) not in N_Op_Compare
+ or else Check not in Minimized_Or_Eliminated
+ or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N)))
+ then
+ return;
+ end if;
+
+ -- OK, this is the case we are interested in. First step is to process
+ -- our operands using the Minimize_Eliminate circuitry which applies
+ -- this processing to the two operand subtrees.
+
+ Minimize_Eliminate_Overflow_Checks (Left_Opnd (N), Llo, Lhi);
+ Minimize_Eliminate_Overflow_Checks (Right_Opnd (N), Rlo, Rhi);
+
+ -- See if the range information decides the result of the comparison
+
+ case N_Op_Compare (Nkind (N)) is
+ when N_Op_Eq =>
+ if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
+ Set_True;
+ elsif Llo > Rhi or else Rlo > Lhi then
+ Set_False;
+ end if;
+
+ when N_Op_Ge =>
+ if Llo >= Rhi then
+ Set_True;
+ elsif Lhi < Rlo then
+ Set_False;
+ end if;
+
+ when N_Op_Gt =>
+ if Llo > Rhi then
+ Set_True;
+ elsif Lhi <= Rlo then
+ Set_False;
+ end if;
+
+ when N_Op_Le =>
+ if Llo > Rhi then
+ Set_False;
+ elsif Lhi <= Rlo then
+ Set_True;
+ end if;
+
+ when N_Op_Lt =>
+ if Llo >= Rhi then
+ Set_True;
+ elsif Lhi < Rlo then
+ Set_False;
+ end if;
+
+ when N_Op_Ne =>
+ if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
+ Set_True;
+ elsif Llo > Rhi or else Rlo > Lhi then
+ Set_False;
+ end if;
+ end case;
+
+ -- All done if we did the rewrite
+
+ if Nkind (N) not in N_Op_Compare then
+ return;
+ end if;
+
+ -- Otherwise, time to do the comparison
+
+ declare
+ Ltype : constant Entity_Id := Etype (Left_Opnd (N));
+ Rtype : constant Entity_Id := Etype (Right_Opnd (N));
+
+ begin
+ -- If the two operands have the same signed integer type we are
+ -- all set, nothing more to do. This is the case where either
+ -- both operands were unchanged, or we rewrote both of them to
+ -- be Long_Long_Integer.
+
+ -- Note: Entity for the comparison may be wrong, but it's not worth
+ -- the effort to change it, since the back end does not use it.
+
+ if Is_Signed_Integer_Type (Ltype)
+ and then Base_Type (Ltype) = Base_Type (Rtype)
+ then
+ return;
+
+ -- Here if bignums are involved (can only happen in ELIMINATED mode)
+
+ elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then
+ declare
+ Left : Node_Id := Left_Opnd (N);
+ Right : Node_Id := Right_Opnd (N);
+ -- Bignum references for left and right operands
+
+ begin
+ if not Is_RTE (Ltype, RE_Bignum) then
+ Left := Convert_To_Bignum (Left);
+ elsif not Is_RTE (Rtype, RE_Bignum) then
+ Right := Convert_To_Bignum (Right);
+ end if;
+
+ -- We need a sequence that looks like
+
+ -- Bnn : Boolean;
+
+ -- declare
+ -- M : Mark_Id := SS_Mark;
+ -- begin
+ -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
+ -- SS_Release (M);
+ -- end;
+
+ -- This block is inserted (using Insert_Actions), and then the
+ -- node is replaced with a reference to Bnn.
+
+ declare
+ Blk : constant Node_Id := Make_Bignum_Block (Loc);
+ Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
+ Ent : RE_Id;
+
+ begin
+ case N_Op_Compare (Nkind (N)) is
+ when N_Op_Eq => Ent := RE_Big_EQ;
+ when N_Op_Ge => Ent := RE_Big_GE;
+ when N_Op_Gt => Ent := RE_Big_GT;
+ when N_Op_Le => Ent := RE_Big_LE;
+ when N_Op_Lt => Ent := RE_Big_LT;
+ when N_Op_Ne => Ent := RE_Big_NE;
+ end case;
+
+ -- Insert assignment to Bnn
+
+ Insert_Before
+ (First (Statements (Handled_Statement_Sequence (Blk))),
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Bnn, Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (Ent), Loc),
+ Parameter_Associations => New_List (Left, Right))));
+
+ -- Insert actions (declaration of Bnn and block)
+
+ Insert_Actions (N, New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Bnn,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
+ Blk));
+
+ -- Rewrite node with reference to Bnn
+
+ Rewrite (N, New_Occurrence_Of (Bnn, Loc));
+ Analyze_And_Resolve (N);
+ end;
+ end;
+
+ -- No bignums involved, but types are different, so we must have
+ -- rewritten one of the operands as a Long_Long_Integer but not
+ -- the other one.
+
+ -- If left operand is Long_Long_Integer, convert right operand
+ -- and we are done (with a comparison of two Long_Long_Integers).
+
+ elsif Ltype = LLIB then
+ Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
+ Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks);
+ return;
+
+ -- If right operand is Long_Long_Integer, convert left operand
+ -- and we are done (with a comparison of two Long_Long_Integers).
+
+ -- This is the only remaining possibility
+
+ else pragma Assert (Rtype = LLIB);
+ Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
+ Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks);
+ return;
+ end if;
+ end;
+ end Expand_Compare_Minimize_Eliminate_Overflow;
+
-------------------------------
-- Expand_Composite_Equality --
-------------------------------
@@ -6367,6 +6602,8 @@
begin
Binary_Op_Validity_Checks (N);
+ -- Deal with private types
+
if Ekind (Typl) = E_Private_Type then
Typl := Underlying_Type (Typl);
elsif Ekind (Typl) = E_Private_Subtype then
@@ -6385,6 +6622,15 @@
Typl := Base_Type (Typl);
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
+ -- results in not having a comparison operation any more, we are done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Eq then
+ return;
+ end if;
+
-- Boolean types (requiring handling of non-standard case)
if Is_Boolean_Type (Typl) then
@@ -6955,11 +7201,24 @@
begin
Binary_Op_Validity_Checks (N);
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
+ -- results in not having a comparison operation any more, we are done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Ge then
+ return;
+ end if;
+
+ -- Array type case
+
if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
+ -- Deal with boolean operands
+
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
@@ -6992,11 +7251,24 @@
begin
Binary_Op_Validity_Checks (N);
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
+ -- results in not having a comparison operation any more, we are done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Gt then
+ return;
+ end if;
+
+ -- Deal with array type operands
+
if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
+ -- Deal with boolean type operands
+
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
@@ -7029,11 +7301,24 @@
begin
Binary_Op_Validity_Checks (N);
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
+ -- results in not having a comparison operation any more, we are done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Le then
+ return;
+ end if;
+
+ -- Deal with array type operands
+
if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
+ -- Deal with Boolean type operands
+
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
@@ -7066,11 +7351,24 @@
begin
Binary_Op_Validity_Checks (N);
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
+ -- results in not having a comparison operation any more, we are done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Lt then
+ return;
+ end if;
+
+ -- Deal with array type operands
+
if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
+ -- Deal with Boolean type operands
+
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
@@ -7447,6 +7745,15 @@
then
Binary_Op_Validity_Checks (N);
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
+ -- that results in not having a /= opertion any more, we are done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Ne then
+ return;
+ end if;
+
-- Boolean types (requiring handling of non-standard case)
if Is_Boolean_Type (Typ) then
This patch enables extended overflow handling for comparison ops so that the comparison can be done in an expanded type, or even in bignum mode if operating in ELIMINATED overflow check mode. The following test program: 1. with Text_IO; use Text_IO; 2. procedure Overflowm2 is 3. function r1 4. (a, b, c, d : Integer) return Boolean is 5. begin 6. return a + b + c + d <= Integer'Last; 7. end; 8. function r2 9. (a, b, c, d : Integer) return Boolean is 10. begin 11. return a * b * c * d >= Integer'First; 12. end; 13. begin 14. begin 15. Put_Line 16. ("r1 returns " & 17. Boolean'Image 18. (r1 (Integer'Last, Integer'Last, 19. -Integer'Last, -Integer'Last))); 20. exception 21. when Constraint_Error => 22. Put_Line ("r1 raises exception"); 23. end; 24. 25. begin 26. Put_Line 27. ("r2 returns " & 28. Boolean'Image 29. (r2 (Integer'Last, Integer'Last, 30. Integer'Last, 0))); 31. exception 32. when Constraint_Error => 33. Put_Line ("r2 raises exception"); 34. end; 35. end Overflowm2; In CHECKED mode (-gnato1) we get: r1 raises exception r2 raises exception since the first addition in r1 and the first multiplication in r2 result in values outside the bounds of Integer'Base. In MINIMIZED mode (-gnato2) we get: r1 returns TRUE r2 raises exception since we can compute the addition result in Long_Long_Integer, and do the comparison in Long_Long_Integer mode, but the second multiplication yields a value outside this range, so that causes an overflow. In ELIMINATE mode (-gnato3) we get: r1 returns TRUE r2 returns TRUE Because now we use Bignum arithmetic for the intermediate multiplication results, and the final comparison is also done in bignum mode. Tested on x86_64-pc-linux-gnu, committed on trunk 2012-10-01 Robert Dewar <dewar@adacore.com> * exp_ch4.adb (Expand_Compare_Minimize_Eliminate_Overflow): New procedure.