[Ada] Raise Constraint_Error in overflow case involving rounding

Function Scaled_Divide in s-arith runtime unit computes the combined
multiplication and division of its arguments ((X*Y) / Z). In a very
special case where the quotient computed before rounding is 2**64-1,
then rounding may lead to undesirable wrap-around, leading to a computed
quotient of 0 instead of raising Constraint_Error as expected.

This function is only called in the runtime for arithmetic operations
involving fixed-point types. Rounding is performed only when the target
type is of a decimal fixed-point type, and the attribute 'Round of the
type is used to round the result of the arithmetic operation.

This fix correctly raises Constraint_Error in this special case.

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

gcc/ada/

	* libgnat/s-arit64.adb (Scaled_Divide): Add protection against
	undesirable wrap-around.

gcc/testsuite/

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

From-SVN: r275791

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 913b30fc7008f4ca835fdb33269e9c8d42034ce2..9a077518eaff33cba2b265c237735d83d1f5a936 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,8 @@
+2019-09-17  Yannick Moy  <moy@adacore.com>
+
+       * libgnat/s-arit64.adb (Scaled_Divide): Add protection against
+       undesirable wrap-around.
+
 2019-09-17  Yannick Moy  <moy@adacore.com>
 
        * libgnat/s-arit64.adb (Double_Divide): Fix two possible

diff --git a/gcc/ada/libgnat/s-arit64.adb b/gcc/ada/libgnat/s-arit64.adb
index a35a40df5cf2f912572c73b3b5b44fe4573f4aae..6773dd8be370de04285b0d7d5ab9d6194bf81c54 100644 (file)
--- a/gcc/ada/libgnat/s-arit64.adb
+++ b/gcc/ada/libgnat/s-arit64.adb
@@ -511,6 +511,14 @@ package body System.Arith_64 is
       --  Deal with rounding case
 
       if Round and then Ru > (Zu - Uns64'(1)) / Uns64'(2) then
+
+         --  Protect against wrapping around when rounding, by signaling
+         --  an overflow when the quotient is too large.
+
+         if Qu = Uns64'Last then
+            Raise_Error;
+         end if;
+
          Qu := Qu + Uns64 (1);
       end if;
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index caed11b9ba3919c9c06bb65228e3ad573fda035c..28d5f264c2374dbe921bda945712c1985e8a1fcd 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-09-17  Yannick Moy  <moy@adacore.com>
+
+       * gnat.dg/multfixed.adb: New testcase.
+
 2019-09-17  Vadim Godunko  <godunko@adacore.com>
 
        * gnat.dg/expect3.adb: New testcase.

diff --git a/gcc/testsuite/gnat.dg/multfixed.adb b/gcc/testsuite/gnat.dg/multfixed.adb
new file mode 100644 (file)
index 0000000..2eca3cd
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/multfixed.adb
@@ -0,0 +1,24 @@
+--  { dg-do run }
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+procedure Multfixed is
+   Z : constant := 4387648782261400837.0;
+   type F1 is delta 1.0 / Z range 0.0 .. (2.0**63-1.0) / Z
+     with Small => 1.0 / Z;
+   type F2 is delta 1.0 range 0.0 .. (2.0**63-1.0)
+     with Small => 1.0;
+   type D is delta 1.0 digits 18;
+
+   X : F1 := 8914588002054909637.0 / Z;
+   Y : F2 := 9079256848778919936.0;
+   U : D;
+begin
+   U := D'Round(X * Y);
+   raise Program_Error;
+exception
+   when Exc : Constraint_Error =>
+      if Exception_Message (Exc) /= "System.Arith_64.Raise_Error: 64-bit arithmetic overflow" then
+         raise Program_Error;
+      end if;
+end Multfixed;
\ No newline at end of file