Fix overflow detection for **, implement ** for i64.

Fix #683

9 files changed, 112 insertions, 32 deletions

diff --git a/src/ghdldrv/ghdlrun.adb b/src/ghdldrv/ghdlrun.adb
index d612095f7..9d1e14343 100644
--- a/src/ghdldrv/ghdlrun.adb
+++ b/src/ghdldrv/ghdlrun.adb
@@ -318,8 +318,10 @@ package body Ghdlrun is
            Grt.Lib.Ghdl_Deallocate'Address);
       Def (Trans_Decls.Ghdl_Real_Exp,
            Grt.Lib.Ghdl_Real_Exp'Address);
-      Def (Trans_Decls.Ghdl_Integer_Exp,
-           Grt.Lib.Ghdl_Integer_Exp'Address);
+      Def (Trans_Decls.Ghdl_I32_Exp,
+           Grt.Lib.Ghdl_I32_Exp'Address);
+      Def (Trans_Decls.Ghdl_I64_Exp,
+           Grt.Lib.Ghdl_I64_Exp'Address);
 
       Def (Trans_Decls.Ghdl_Sensitized_Process_Register,
            Grt.Processes.Ghdl_Sensitized_Process_Register'Address);
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,16 +191,53 @@ 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");
       end if;
@@ -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;
diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb
index c9e639dd1..7938a278d 100644
--- a/src/vhdl/translate/trans-chap3.adb
+++ b/src/vhdl/translate/trans-chap3.adb
@@ -3233,8 +3233,7 @@ package body Trans.Chap3 is
          Allocate_Unbounded_Composite_Bounds (Alloc_Kind, Res, Obj_Type);
          Copy_Bounds (Chap3.Get_Composite_Bounds (Res), Bounds, Obj_Type);
          --  Allocate base.
-         Allocate_Unbounded_Composite_Base
-           (Alloc_Kind, Res, Obj_Type);
+         Allocate_Unbounded_Composite_Base (Alloc_Kind, Res, Obj_Type);
       else
          New_Assign_Stmt
            (M2Lp (Res),
diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb
index 20f7185d1..a0352a4dd 100644
--- a/src/vhdl/translate/trans-chap7.adb
+++ b/src/vhdl/translate/trans-chap7.adb
@@ -2456,11 +2456,24 @@ package body Trans.Chap7 is
                Right_Tree, Ghdl_Real_Exp);
             return New_Convert_Ov (Res, Res_Otype);
          when Iir_Predefined_Integer_Exp =>
-            Res := Translate_Lib_Operator
-              (New_Convert_Ov (Left_Tree, Std_Integer_Otype),
-               Right_Tree,
-               Ghdl_Integer_Exp);
-            return New_Convert_Ov (Res, Res_Otype);
+            declare
+               Left_Tinfo : constant Type_Info_Acc :=
+                 Get_Info (Get_Type (Left));
+               Opr : O_Dnode;
+               Etype : O_Tnode;
+            begin
+               case Type_Mode_Integers (Left_Tinfo.Type_Mode) is
+                  when Type_Mode_I32 =>
+                     Opr := Ghdl_I32_Exp;
+                     Etype := Ghdl_I32_Type;
+                  when Type_Mode_I64 =>
+                     Opr := Ghdl_I64_Exp;
+                     Etype := Ghdl_I64_Type;
+               end case;
+               Res := Translate_Lib_Operator
+                 (New_Convert_Ov (Left_Tree, Etype), Right_Tree, Opr);
+               return New_Convert_Ov (Res, Res_Otype);
+            end;
 
          when Iir_Predefined_Array_Inequality
             | Iir_Predefined_Record_Inequality =>
diff --git a/src/vhdl/translate/trans.ads b/src/vhdl/translate/trans.ads
index 960323ee8..f154d6d5d 100644
--- a/src/vhdl/translate/trans.ads
+++ b/src/vhdl/translate/trans.ads
@@ -1063,6 +1063,9 @@ package Trans is
    subtype Type_Mode_Scalar is Type_Mode_Type range
      Type_Mode_B1 .. Type_Mode_F64;
 
+   subtype Type_Mode_Integers is Type_Mode_Type range
+     Type_Mode_I32 .. Type_Mode_I64;
+
    --  Composite types, with the vhdl meaning: record and arrays.
    subtype Type_Mode_Composite is Type_Mode_Type range
      Type_Mode_Static_Record .. Type_Mode_Protected;
diff --git a/src/vhdl/translate/trans_decls.ads b/src/vhdl/translate/trans_decls.ads
index d0011e653..2f9fa539a 100644
--- a/src/vhdl/translate/trans_decls.ads
+++ b/src/vhdl/translate/trans_decls.ads
@@ -164,7 +164,8 @@ package Trans_Decls is
    Ghdl_Malloc : O_Dnode;
    Ghdl_Malloc0 : O_Dnode;
    Ghdl_Real_Exp : O_Dnode;
-   Ghdl_Integer_Exp : O_Dnode;
+   Ghdl_I32_Exp : O_Dnode;
+   Ghdl_I64_Exp : O_Dnode;
 
    --  Procedure called in case of check failed.
    Ghdl_Program_Error : O_Dnode;
diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb
index 68dd9a300..2edeba0be 100644
--- a/src/vhdl/translate/translation.adb
+++ b/src/vhdl/translate/translation.adb
@@ -1139,16 +1139,25 @@ package body Translation is
                           Std_Integer_Otype);
       Finish_Subprogram_Decl (Interfaces, Ghdl_Real_Exp);
 
-      --  function __ghdl_integer_exp (left : std__standard__integer;
-      --                               right : std__standard__integer)
-      --   return std__standard__integer;
+      --  function __ghdl_i32_exp (left : ghdl_i32;
+      --                           right : std__standard__integer)
+      --   return ghdl_i32;
       Start_Function_Decl
-        (Interfaces, Get_Identifier ("__ghdl_integer_exp"), O_Storage_External,
-         Std_Integer_Otype);
-      New_Interface_Decl (Interfaces, Param, Wki_Left, Std_Integer_Otype);
+        (Interfaces, Get_Identifier ("__ghdl_i32_exp"), O_Storage_External,
+         Ghdl_I32_Type);
+      New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_I32_Type);
       New_Interface_Decl (Interfaces, Param, Wki_Right, Std_Integer_Otype);
-      Finish_Subprogram_Decl (Interfaces, Ghdl_Integer_Exp);
+      Finish_Subprogram_Decl (Interfaces, Ghdl_I32_Exp);
 
+      --  function __ghdl_i64_exp (left : ghdl_i64;
+      --                           right : std__standard__integer)
+      --   return ghdl_i64;
+      Start_Function_Decl
+        (Interfaces, Get_Identifier ("__ghdl_i64_exp"), O_Storage_External,
+         Ghdl_I64_Type);
+      New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_I64_Type);
+      New_Interface_Decl (Interfaces, Param, Wki_Right, Std_Integer_Otype);
+      Finish_Subprogram_Decl (Interfaces, Ghdl_I64_Exp);
 
       --  procedure __ghdl_image_b1 (res : std_string_ptr_node;
       --                             val : ghdl_bool_type;