From d4ba72cbad263d9b4fd211534c117343ed5333a1 Mon Sep 17 00:00:00 2001 From: Yannick Moy Date: Tue, 17 Sep 2019 08:02:30 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 5 +++++ gcc/ada/libgnat/s-arit64.adb | 8 ++++++++ gcc/testsuite/ChangeLog | 4 ++++ gcc/testsuite/gnat.dg/multfixed.adb | 24 ++++++++++++++++++++++++ 4 files changed, 41 insertions(+) create mode 100644 gcc/testsuite/gnat.dg/multfixed.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 913b30fc700..9a077518eaf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2019-09-17 Yannick Moy + + * libgnat/s-arit64.adb (Scaled_Divide): Add protection against + undesirable wrap-around. + 2019-09-17 Yannick Moy * 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 a35a40df5cf..6773dd8be37 100644 --- 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 caed11b9ba3..28d5f264c23 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-09-17 Yannick Moy + + * gnat.dg/multfixed.adb: New testcase. + 2019-09-17 Vadim Godunko * 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 index 00000000000..2eca3cde7ed --- /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 -- 2.30.2