From 67460d45757a79cdc91fdde1dc1b1a18e4aba6b2 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 23 Jul 2019 08:13:32 +0000 Subject: [PATCH] [Ada] Plug small loophole in Generate_Range_Check The Generate_Range_Check routine is responsible for generating range checks in the scalar case. It automatically deals with possible overflow in the process when the source and the target base types are different. However there is one case where overflow is not dealt with correctly, namely when the target base type is narrower than the source base type and both are floating-point types. In this case, the routine will convert the source type to the target base type without checking for overflow. In practice this does not matter much because the conversion would yield an infinity on overflow, which would then fail the subsequent range check. However it's more correct to have a proper overflow check with -gnateF than relying on the infinity. 2019-07-23 Eric Botcazou gcc/ada/ * checks.adb (Convert_And_Check_Range): Add Suppress parameter and pass it in the call to Insert_Actions. Rename local variable. (Generate_Range_Check): Minor comment fixes. Pass Range_Check in the first call to Convert_And_Check_Range and All_Checks in the second call. * exp_ch4.adb (Expand_N_Type_Conversion): Reset the Do_Overflow_Check flag in the float-to-float case too if there is also a range check. gcc/testsuite/ * gnat.dg/range_check5.adb: New testcase. From-SVN: r273725 --- gcc/ada/ChangeLog | 12 +++++ gcc/ada/checks.adb | 68 +++++++++++++------------- gcc/ada/exp_ch4.adb | 5 ++ gcc/testsuite/ChangeLog | 4 ++ gcc/testsuite/gnat.dg/range_check5.adb | 21 ++++++++ 5 files changed, 75 insertions(+), 35 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/range_check5.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 786949565d0..86a5491ad34 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2019-07-23 Eric Botcazou + + * checks.adb (Convert_And_Check_Range): Add Suppress parameter + and pass it in the call to Insert_Actions. Rename local + variable. + (Generate_Range_Check): Minor comment fixes. Pass Range_Check + in the first call to Convert_And_Check_Range and All_Checks in + the second call. + * exp_ch4.adb (Expand_N_Type_Conversion): Reset the + Do_Overflow_Check flag in the float-to-float case too if there + is also a range check. + 2019-07-23 Eric Botcazou * checks.adb (Activate_Overflow_Check): Remove redundant diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 2eff274e7d0..708bd9e66f7 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6841,18 +6841,19 @@ package body Checks is Source_Base_Type : constant Entity_Id := Base_Type (Source_Type); Target_Base_Type : constant Entity_Id := Base_Type (Target_Type); - procedure Convert_And_Check_Range; - -- Convert the conversion operand to the target base type and save in - -- a temporary. Then check the converted value against the range of the - -- target subtype. + procedure Convert_And_Check_Range (Suppress : Check_Id); + -- Convert N to the target base type and save the result in a temporary. + -- The action is analyzed using the default checks as modified by the + -- given Suppress argument. Then check the converted value against the + -- range of the target subtype. ----------------------------- -- Convert_And_Check_Range -- ----------------------------- - procedure Convert_And_Check_Range is - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); - Conv_Node : Node_Id; + procedure Convert_And_Check_Range (Suppress : Check_Id) is + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Conv_N : Node_Id; begin -- For enumeration types with non-standard representation this is a @@ -6867,36 +6868,26 @@ package body Checks is and then Present (Enum_Pos_To_Rep (Source_Base_Type)) and then Is_Integer_Type (Target_Base_Type) then - Conv_Node := - OK_Convert_To - (Typ => Target_Base_Type, - Expr => Duplicate_Subexpr (N)); - - -- Common case - + Conv_N := OK_Convert_To (Target_Base_Type, Duplicate_Subexpr (N)); else - Conv_Node := - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc), - Expression => Duplicate_Subexpr (N)); + Conv_N := Convert_To (Target_Base_Type, Duplicate_Subexpr (N)); end if; - -- We make a temporary to hold the value of the converted value - -- (converted to the base type), and then do the test against this - -- temporary. The conversion itself is replaced by an occurrence of - -- Tnn and followed by the explicit range check. Note that checks - -- are suppressed for this code, since we don't want a recursive - -- range check popping up. + -- We make a temporary to hold the value of the conversion to the + -- target base type, and then do the test against this temporary. + -- N itself is replaced by an occurrence of Tnn and followed by + -- the explicit range check. -- Tnn : constant Target_Base_Type := Target_Base_Type (N); -- [constraint_error when Tnn not in Target_Type] + -- Tnn Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Tnn, Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc), Constant_Present => True, - Expression => Conv_Node), + Expression => Conv_N), Make_Raise_Constraint_Error (Loc, Condition => @@ -6904,7 +6895,7 @@ package body Checks is Left_Opnd => New_Occurrence_Of (Tnn, Loc), Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), Reason => Reason)), - Suppress => All_Checks); + Suppress => Suppress); Rewrite (N, New_Occurrence_Of (Tnn, Loc)); @@ -6921,7 +6912,7 @@ package body Checks is -- First special case, if the source type is already within the range -- of the target type, then no check is needed (probably we should have -- stopped Do_Range_Check from being set in the first place, but better - -- late than never in preventing junk code and junk flag settings. + -- late than never in preventing junk code and junk flag settings). if In_Subrange_Of (Source_Type, Target_Type) @@ -6998,7 +6989,8 @@ package body Checks is -- Next test for the case where the target type is within the bounds -- of the base type of the source type, since in this case we can - -- simply convert these bounds to the base type of T to do the test. + -- simply convert the bounds of the target type to this base bype + -- to do the test. -- [constraint_error when N not in -- Source_Base_Type (Target_Type'First) @@ -7047,14 +7039,18 @@ package body Checks is Suppress => All_Checks); -- For conversions involving at least one type that is not discrete, - -- first convert to target type and then generate the range check. - -- This avoids problems with values that are close to a bound of the - -- target type that would fail a range check when done in a larger - -- source type before converting but would pass if converted with + -- first convert to the target base type and then generate the range + -- check. This avoids problems with values that are close to a bound + -- of the target type that would fail a range check when done in a + -- larger source type before converting but pass if converted with -- rounding and then checked (such as in float-to-float conversions). + -- Note that overflow checks are not suppressed for this code because + -- we do not know whether the source type is in range of the target + -- base type (unlike in the next case below). + else - Convert_And_Check_Range; + Convert_And_Check_Range (Suppress => Range_Check); end if; -- Note that at this stage we know that the Target_Base_Type is not in @@ -7063,10 +7059,12 @@ package body Checks is -- in range of the target base type since we have not checked that case. -- If that is the case, we can freely convert the source to the target, - -- and then test the target result against the bounds. + -- and then test the target result against the bounds. Note that checks + -- are suppressed for this code, since we don't want a recursive range + -- check popping up. elsif In_Subrange_Of (Source_Type, Target_Base_Type) then - Convert_And_Check_Range; + Convert_And_Check_Range (Suppress => All_Checks); -- At this stage, we know that we have two scalar types, which are -- directly convertible, and where neither scalar type has a base diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 2af54a7d50b..e4dc06b5d6a 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -12090,6 +12090,11 @@ package body Exp_Ch4 is if Is_Floating_Point_Type (Target_Type) and then Is_Floating_Point_Type (Etype (Expression (N))) then + -- Reset overflow flag, since the range check will include + -- dealing with possible overflow, and generate the check. + + Set_Do_Overflow_Check (N, False); + Generate_Range_Check (Expression (N), Target_Type, CE_Range_Check_Failed); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 03cf4bb52dd..883befdbf67 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-07-23 Eric Botcazou + + * gnat.dg/range_check5.adb: New testcase. + 2019-07-23 Ed Schonberg * gnat.dg/iter5.adb: Add an expected error. diff --git a/gcc/testsuite/gnat.dg/range_check5.adb b/gcc/testsuite/gnat.dg/range_check5.adb new file mode 100644 index 00000000000..dd622964d46 --- /dev/null +++ b/gcc/testsuite/gnat.dg/range_check5.adb @@ -0,0 +1,21 @@ +-- { dg-do run } +-- { dg-options "-gnateF -O0" } + +procedure Range_Check5 is + + subtype Small_Float is Float range -100.0 .. 100.0; + + function Conv (F : Long_Float) return Small_Float is + begin + return Small_Float (F); + end; + + R : Small_Float; + +begin + R := Conv (4.0E+38); + raise Program_Error; +exception + when Constraint_Error => + null; +end; -- 2.30.2