[Ada] Factor out machine rounding operations

gcc/ada/

	* sem_eval.ads (Machine_Number): New inline function.
	* sem_eval.adb (Machine_Number): New function body implementing
	the machine rounding operation specified by RM 4.9(38/2).
	(Check_Non_Static_Context): Call Machine_Number and set the
	Is_Machine_Number flag consistently on the resulting node.
	* sem_attr.adb (Eval_Attribute) <Attribute_Machine>: Likewise.
	* checks.adb (Apply_Float_Conversion_Check): Call Machine_Number.
	(Round_Machine): Likewise.

4 files changed, 39 insertions, 23 deletions

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index c06012b..c85cba9a5 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -2171,7 +2171,7 @@ package body Checks is
          Lo_OK := (Ifirst > 0);
 
       else
-         Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Expr);
+         Lo := Machine_Number (Expr_Type, UR_From_Uint (Ifirst), Expr);
          Lo_OK := (Lo >= UR_From_Uint (Ifirst));
       end if;
 
@@ -2214,7 +2214,7 @@ package body Checks is
          Hi := UR_From_Uint (Ilast) + Ureal_Half;
          Hi_OK := (Ilast < 0);
       else
-         Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Expr);
+         Hi := Machine_Number (Expr_Type, UR_From_Uint (Ilast), Expr);
          Hi_OK := (Hi <= UR_From_Uint (Ilast));
       end if;
 
@@ -5563,7 +5563,7 @@ package body Checks is
       --  the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
 
       function Round_Machine (B : Ureal) return Ureal;
-      --  B is a real bound. Round it using mode Round_Even.
+      --  B is a real bound. Round it to the nearest machine number.
 
       -----------------
       -- OK_Operands --
@@ -5589,7 +5589,7 @@ package body Checks is
 
       function Round_Machine (B : Ureal) return Ureal is
       begin
-         return Machine (Typ, B, Round_Even, N);
+         return Machine_Number (Typ, B, N);
       end Round_Machine;
 
    --  Start of processing for Determine_Range_R
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 32c5d37..f2bb12d 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -9251,14 +9251,12 @@ package body Sem_Attr is
       -- Machine --
       -------------
 
-      --  We use the same rounding mode as the one used for RM 4.9(38)
+      --  We use the same rounding as the one used for RM 4.9(38/2)
 
       when Attribute_Machine =>
          Fold_Ureal
-           (N,
-            Eval_Fat.Machine
-              (P_Base_Type, Expr_Value_R (E1), Eval_Fat.Round_Even, N),
-            Static);
+           (N, Machine_Number (P_Base_Type, Expr_Value_R (E1), N), Static);
+         Set_Is_Machine_Number (N);
 
       ------------------
       -- Machine_Emax --
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 954a4a6..e3308ef 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -523,8 +523,8 @@ package body Sem_Eval is
               and then Nkind (Parent (N)) in N_Subexpr
             then
                Rewrite (N, New_Copy (N));
-               Set_Realval
-                 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
+               Set_Realval (N, Machine_Number (Base_Type (T), Realval (N), N));
+               Set_Is_Machine_Number (N);
             end if;
          end if;
 
@@ -575,18 +575,7 @@ package body Sem_Eval is
               (N, Corresponding_Integer_Value (N) * Small_Value (T));
 
          elsif not UR_Is_Zero (Realval (N)) then
-
-            --  Note: even though RM 4.9(38) specifies biased rounding, this
-            --  has been modified by AI-100 in order to prevent confusing
-            --  differences in rounding between static and non-static
-            --  expressions. AI-100 specifies that the effect of such rounding
-            --  is implementation dependent, and in GNAT we round to nearest
-            --  even to match the run-time behavior. Note that this applies
-            --  to floating point literals, not fixed points ones, even though
-            --  their compiler representation is also as a universal real.
-
-            Set_Realval
-              (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
+            Set_Realval (N, Machine_Number (Base_Type (T), Realval (N), N));
             Set_Is_Machine_Number (N);
          end if;
 
@@ -6046,6 +6035,27 @@ package body Sem_Eval is
    end Is_Statically_Unevaluated;
 
    --------------------
+   -- Machine_Number --
+   --------------------
+
+   --  Historical note: RM 4.9(38) originally specified biased rounding but
+   --  this has been modified by AI-268 to prevent confusing differences in
+   --  rounding between static and nonstatic expressions. This AI specifies
+   --  that the effect of such rounding is implementation-dependent instead,
+   --  and in GNAT we round to nearest even to match the run-time behavior.
+   --  Note that this applies to floating-point literals, not fixed-point
+   --  ones, even though their representation is also a universal real.
+
+   function Machine_Number
+     (Typ : Entity_Id;
+      Val : Ureal;
+      N   : Node_Id) return Ureal
+   is
+   begin
+      return Machine (Typ, Val, Round_Even, N);
+   end Machine_Number;
+
+   --------------------
    -- Not_Null_Range --
    --------------------
 
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index c93d97d..c2e08b6 100644
--- a/gcc/ada/sem_eval.ads
+++ b/gcc/ada/sem_eval.ads
@@ -486,6 +486,13 @@ package Sem_Eval is
    --  it cannot be determined at compile time. Flag Fixed_Int is used as in
    --  routine Is_In_Range above.
 
+   function Machine_Number
+     (Typ : Entity_Id;
+      Val : Ureal;
+      N   : Node_Id) return Ureal;
+   --  Return the machine number of Typ corresponding to the specified Val as
+   --  per RM 4.9(38/2). N is a node only used to post warnings.
+
    function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
    --  Returns True if it can guarantee that Lo .. Hi is not a null range. If
    --  it cannot (because the value of Lo or Hi is not known at compile time)
@@ -574,5 +581,6 @@ private
    pragma Inline (Eval_Unchecked_Conversion);
 
    pragma Inline (Is_OK_Static_Expression);
+   pragma Inline (Machine_Number);
 
 end Sem_Eval;