From 279fcbc246fc6438756b76cd4d3d5f1f3e4e1463 Mon Sep 17 00:00:00 2001
From: Tristan Gingold <tgingold@free.fr>
Date: Wed, 14 Nov 2018 06:39:53 +0100
Subject: Fix overflow detection for **, implement ** for i64.

Fix #683
---
 src/grt/grt-lib.adb   | 73 ++++++++++++++++++++++++++++++++++++++++++---------
 src/grt/grt-lib.ads   |  7 ++---
 src/grt/grt-types.ads |  3 +++
 3 files changed, 68 insertions(+), 15 deletions(-)

(limited to 'src/grt')

diff --git a/src/grt/grt-lib.adb b/src/grt/grt-lib.adb
index 2442998fe..3a9a9f6c3 100644
--- a/src/grt/grt-lib.adb
+++ b/src/grt/grt-lib.adb
@@ -191,15 +191,52 @@ package body Grt.Lib is
       Error_E_Call_Stack (Bt);
    end Ghdl_Direction_Check_Failed;
 
-   function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32)
-     return Ghdl_I32
-   is
-      pragma Suppress (Overflow_Check);
+   function Hi (V : Ghdl_I64) return Ghdl_U32 is
+   begin
+      return Ghdl_U32 (Shift_Right (To_Ghdl_U64 (V), 32) and 16#ffff_ffff#);
+   end Hi;
 
-      R : Ghdl_I32;
-      Res : Ghdl_I32;
-      P : Ghdl_I32;
+   function Lo (V : Ghdl_I64) return Ghdl_U32 is
+   begin
+      return Ghdl_U32 (To_Ghdl_U64 (V) and 16#ffff_ffff#);
+   end Lo;
+
+   procedure Mul_I32_Ovf (L, R : Ghdl_I32;
+                          Res : out Ghdl_I32;
+                          Ovf : out Boolean)
+   is
       T : Ghdl_I64;
+   begin
+      T := Ghdl_I64 (L) * Ghdl_I64 (R);
+      if Hi (T) /= Shift_Right_Arithmetic (Lo (T), 31) then
+         Ovf := True;
+      else
+         Ovf := False;
+         Res := Ghdl_I32 (T);
+      end if;
+   end Mul_I32_Ovf;
+
+   procedure Mul_I64_Ovf (L, R : Ghdl_I64;
+                          Res : out Ghdl_I64;
+                          Ovf : out Boolean) is
+   begin
+      --  TODO: check overflow.
+      Res := L * R;
+      Ovf := False;
+   end Mul_I64_Ovf;
+
+   generic
+      type T is range <>;
+      with procedure Mul_Ovf (L, R : T; Res : out T; Ovf : out Boolean);
+   function Gen_Ixx_Exp (V : T; E : Std_Integer) return T;
+   pragma Convention (C, Gen_Ixx_Exp);
+
+   function Gen_Ixx_Exp (V : T; E : Std_Integer) return T
+   is
+      R : Std_Integer;
+      Res : T;
+      P : T;
+      Ovf : Boolean;
    begin
       if E < 0 then
          Error ("negative exponent");
@@ -209,18 +246,30 @@ package body Grt.Lib is
       R := E;
       loop
          if R mod 2 = 1 then
-            T := Ghdl_I64 (Res) * Ghdl_I64 (P);
-            Res := Ghdl_I32 (T);
-            if Ghdl_I64 (Res) /= T then
+            Mul_Ovf (Res, P, Res, Ovf);
+            if Ovf then
                Error ("overflow in exponentiation");
             end if;
          end if;
          R := R / 2;
          exit when R = 0;
-         P := P * P;
+         Mul_Ovf (P, P, P, Ovf);
+         if Ovf then
+            Error ("overflow in exponentiation");
+         end if;
       end loop;
       return Res;
-   end Ghdl_Integer_Exp;
+   end Gen_Ixx_Exp;
+
+   function Ghdl_I32_Exp_1 is new Gen_Ixx_Exp (Ghdl_I32, Mul_I32_Ovf);
+
+   function Ghdl_I32_Exp (V : Ghdl_I32; E : Std_Integer) return Ghdl_I32
+     renames Ghdl_I32_Exp_1;
+
+   function Ghdl_I64_Exp_1 is new Gen_Ixx_Exp (Ghdl_I64, Mul_I64_Ovf);
+
+   function Ghdl_I64_Exp (V : Ghdl_I64; E : Std_Integer) return Ghdl_I64
+     renames Ghdl_I64_Exp_1;
 
    function C_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr;
    pragma Import (C, C_Malloc, "malloc");
diff --git a/src/grt/grt-lib.ads b/src/grt/grt-lib.ads
index 69c8a4c34..646cdd5fb 100644
--- a/src/grt/grt-lib.ads
+++ b/src/grt/grt-lib.ads
@@ -67,8 +67,8 @@ package Grt.Lib is
                                  Line : Ghdl_I32;
                                  Code : Ghdl_Index_Type);
 
-   function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32)
-     return Ghdl_I32;
+   function Ghdl_I32_Exp (V : Ghdl_I32; E : Std_Integer) return Ghdl_I32;
+   function Ghdl_I64_Exp (V : Ghdl_I64; E : Std_Integer) return Ghdl_I64;
 
    function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr;
 
@@ -126,7 +126,8 @@ private
    pragma Export (C, Ghdl_Malloc0, "__ghdl_malloc0");
    pragma Export (C, Ghdl_Deallocate, "__ghdl_deallocate");
 
-   pragma Export (C, Ghdl_Integer_Exp, "__ghdl_integer_exp");
+   pragma Export (C, Ghdl_I32_Exp, "__ghdl_i32_exp");
+   pragma Export (C, Ghdl_I64_Exp, "__ghdl_i64_exp");
    pragma Export (C, Ghdl_Real_Exp, "__ghdl_real_exp");
 
    pragma Export (C, Ghdl_Std_Ulogic_To_Boolean_Array,
diff --git a/src/grt/grt-types.ads b/src/grt/grt-types.ads
index f75711eeb..fdabf4368 100644
--- a/src/grt/grt-types.ads
+++ b/src/grt/grt-types.ads
@@ -39,6 +39,9 @@ package Grt.Types is
    type Ghdl_U64 is new Unsigned_64;
    type Ghdl_F64 is new IEEE_Float_64;
 
+   function To_Ghdl_U64 is new Ada.Unchecked_Conversion
+     (Ghdl_I64, Ghdl_U64);
+
    type Ghdl_Ptr is new Address;
    type Ghdl_Index_Type is mod 2 ** 32;
    subtype Ghdl_Real is Ghdl_F64;
-- 
cgit v1.2.3