[Ada] Plug small loophole in Generate_Range_Check

[Pierre-Marie de Rodat <derodat at adacore dot com>]

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.

Tested on x86_64-pc-linux-gnu, committed on trunk

2019-07-23  Eric Botcazou  <ebotcazou@adacore.com>

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.

--- gcc/ada/checks.adb
+++ 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

--- gcc/ada/exp_ch4.adb
+++ 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);
 

--- /dev/null
new file mode 100644
+++ 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;