[Ada] Fix rounding of fixed-point arithmetic operation

Fixed-point multiplication, division and conversion may lead to calling
the function Double_Divide in s-arit64 runtime unit. In the special case
where arguments have the special values X = -2**63 and the absolute
value of the product of its other arguments Y*Z = 2**64, the rounded
value should be either -1 or 1, but currently Double_Divide returns a
quotient of 0.

Rounding only applies when Round attribute is called on the arithmetic
operation for a decimal fixed-point result, or the result type is
integer.

This fixes correctly applies rounding away from 0 in that special case.

2019-09-17  Yannick Moy  <moy@adacore.com>

gcc/ada/

	* libgnat/s-arit64.adb (Double_Divide): Correctly handle the
	special case when rounding.

gcc/testsuite/

	* gnat.dg/fixedpnt7.adb: New testcase.

From-SVN: r275796

4 files changed, 64 insertions, 8 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 36a7dde..6c4eaf7 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,8 @@
+2019-09-17  Yannick Moy  <moy@adacore.com>
+
+	* libgnat/s-arit64.adb (Double_Divide): Correctly handle the
+	special case when rounding.
+
 2019-09-17  Javier Miranda  <miranda@adacore.com>
 
 	* sem_ch3.adb (Complete_Private_Subtype): Propagate attributes
diff --git a/gcc/ada/libgnat/s-arit64.adb b/gcc/ada/libgnat/s-arit64.adb
index b5a5ac4..ede7562 100644
--- a/gcc/ada/libgnat/s-arit64.adb
+++ b/gcc/ada/libgnat/s-arit64.adb
@@ -147,13 +147,31 @@ package body System.Arith_64 is
          Raise_Error;
       end if;
 
+      --  Set final signs (RM 4.5.5(27-30))
+
+      Den_Pos := (Y < 0) = (Z < 0);
+
       --  Compute Y * Z. Note that if the result overflows 64 bits unsigned,
-      --  then the rounded result is clearly zero (since the dividend is at
-      --  most 2**63 - 1, the extra bit of precision is nice here).
+      --  then the rounded result is zero, except for the very special case
+      --  where X = -2**63 and abs(Y*Z) = 2**64, when Round is True.
 
       if Yhi /= 0 then
          if Zhi /= 0 then
-            Q := 0;
+
+            --  Handle the special case when Round is True
+
+            if Yhi = 1
+              and then Zhi = 1
+              and then Ylo = 0
+              and then Zlo = 0
+              and then X = Int64'First
+              and then Round
+            then
+               Q := (if Den_Pos then -1 else 1);
+            else
+               Q := 0;
+            end if;
+
             R := X;
             return;
          else
@@ -168,17 +186,26 @@ package body System.Arith_64 is
       T2 := T2 + Hi (T1);
 
       if Hi (T2) /= 0 then
-         Q := 0;
+
+         --  Handle the special case when Round is True
+
+         if Hi (T2) = 1
+           and then Lo (T2) = 0
+           and then Lo (T1) = 0
+           and then X = Int64'First
+           and then Round
+         then
+            Q := (if Den_Pos then -1 else 1);
+         else
+            Q := 0;
+         end if;
+
          R := X;
          return;
       end if;
 
       Du := Lo (T2) & Lo (T1);
 
-      --  Set final signs (RM 4.5.5(27-30))
-
-      Den_Pos := (Y < 0) = (Z < 0);
-
       --  Check overflow case of largest negative number divided by -1
 
       if X = Int64'First and then Du = 1 and then not Den_Pos then
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 28d5f26..56d58cc 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,9 @@
 2019-09-17  Yannick Moy  <moy@adacore.com>
 
+	* gnat.dg/fixedpnt7.adb: New testcase.
+
+2019-09-17  Yannick Moy  <moy@adacore.com>
+
 	* gnat.dg/multfixed.adb: New testcase.
 
 2019-09-17  Vadim Godunko  <godunko@adacore.com>
diff --git a/gcc/testsuite/gnat.dg/fixedpnt7.adb b/gcc/testsuite/gnat.dg/fixedpnt7.adb
new file mode 100644
index 0000000..635b984
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/fixedpnt7.adb
@@ -0,0 +1,20 @@
+--  { dg-do run }
+
+procedure Fixedpnt7 is
+   type F1 is delta 1.0 range -2.0**63 .. 0.0
+     with Small => 1.0;
+   type F2 is delta 4.0 range 0.0 .. 2.0**64
+     with Small => 4.0;
+   type D is delta 1.0 digits 18;
+
+   XX : constant := -2.0**63;
+   YY : constant := 2.0**64;
+
+   X : F1 := XX;
+   Y : F2 := YY;
+   U : D := D'Round(X / Y);
+begin
+   if U /= -1.0 then
+      raise Program_Error;
+   end if;
+end Fixedpnt7;
\ No newline at end of file