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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2019-09-17 Yannick Moy <m...@adacore.com>
gcc/ada/
* libgnat/s-arit64.adb (Scaled_Divide): Add protection against
undesirable wrap-around.
gcc/testsuite/
* gnat.dg/multfixed.adb: New testcase.--- gcc/ada/libgnat/s-arit64.adb
+++ 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;
--- /dev/null
new file mode 100644
+++ 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
