vhdl: handle force/release statements in translate and grt. For #1416

3 files changed, 205 insertions, 18 deletions

diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb
index 1e7bb1956..465fa3af5 100644
--- a/src/vhdl/translate/trans-chap8.adb
+++ b/src/vhdl/translate/trans-chap8.adb
@@ -4843,8 +4843,131 @@ package body Trans.Chap8 is
       Close_Temp;
    end Translate_Selected_Waveform_Assignment_Statement;
 
-   procedure Translate_Statement (Stmt : Iir)
+   procedure Translate_Signal_Release_Assignment_Statement (Stmt : Iir)
    is
+      Target : constant Iir := Get_Target (Stmt);
+      Targ : Mnode;
+      Proc : O_Dnode;
+   begin
+      Targ := Chap6.Translate_Name (Target, Mode_Signal);
+      case Get_Force_Mode (Stmt) is
+         when Iir_Force_In =>
+            Proc := Ghdl_Signal_Release_Eff;
+         when Iir_Force_Out =>
+            Proc := Ghdl_Signal_Release_Drv;
+      end case;
+      Register_Signal (Targ, Get_Type (Target), Proc);
+   end Translate_Signal_Release_Assignment_Statement;
+
+   Signal_Force_Stmt : Iir;
+   procedure Gen_Signal_Force_Non_Composite (Targ      : Mnode;
+                                             Targ_Type : Iir;
+                                             Val       : O_Enode)
+   is
+      Type_Info : constant Type_Info_Acc := Get_Info (Targ_Type);
+      Subprg    : O_Dnode;
+      Conv      : O_Tnode;
+      Assoc     : O_Assoc_List;
+      Val2      : O_Enode;
+   begin
+      case Type_Mode_Scalar (Type_Info.Type_Mode) is
+         when Type_Mode_B1 =>
+            case Get_Force_Mode (Signal_Force_Stmt) is
+               when Iir_Force_In =>
+                  Subprg := Ghdl_Signal_Force_Eff_B1;
+               when Iir_Force_Out =>
+                  Subprg := Ghdl_Signal_Force_Drv_B1;
+            end case;
+            Conv := Ghdl_Bool_Type;
+         when Type_Mode_E8 =>
+            case Get_Force_Mode (Signal_Force_Stmt) is
+               when Iir_Force_In =>
+                  Subprg := Ghdl_Signal_Force_Eff_E8;
+               when Iir_Force_Out =>
+                  Subprg := Ghdl_Signal_Force_Drv_E8;
+            end case;
+            Conv := Ghdl_I32_Type;
+         when Type_Mode_E32 =>
+            case Get_Force_Mode (Signal_Force_Stmt) is
+               when Iir_Force_In =>
+                  Subprg := Ghdl_Signal_Force_Eff_E32;
+               when Iir_Force_Out =>
+                  Subprg := Ghdl_Signal_Force_Drv_E32;
+            end case;
+            Conv := Ghdl_I32_Type;
+         when Type_Mode_I32
+            | Type_Mode_P32 =>
+            case Get_Force_Mode (Signal_Force_Stmt) is
+               when Iir_Force_In =>
+                  Subprg := Ghdl_Signal_Force_Eff_I32;
+               when Iir_Force_Out =>
+                  Subprg := Ghdl_Signal_Force_Drv_I32;
+            end case;
+            Conv := Ghdl_I32_Type;
+         when Type_Mode_P64
+            | Type_Mode_I64 =>
+            case Get_Force_Mode (Signal_Force_Stmt) is
+               when Iir_Force_In =>
+                  Subprg := Ghdl_Signal_Force_Eff_I64;
+               when Iir_Force_Out =>
+                  Subprg := Ghdl_Signal_Force_Drv_I64;
+            end case;
+            Conv := Ghdl_I64_Type;
+         when Type_Mode_F64 =>
+            case Get_Force_Mode (Signal_Force_Stmt) is
+               when Iir_Force_In =>
+                  Subprg := Ghdl_Signal_Force_Eff_F64;
+               when Iir_Force_Out =>
+                  Subprg := Ghdl_Signal_Force_Drv_F64;
+            end case;
+            Conv := Ghdl_Real_Type;
+      end case;
+      Val2 := Chap3.Insert_Scalar_Check
+        (Val, Null_Iir, Targ_Type, Signal_Force_Stmt);
+      Start_Association (Assoc, Subprg);
+      New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)),
+                                              Ghdl_Signal_Ptr));
+      New_Association (Assoc, New_Convert_Ov (Val2, Conv));
+      New_Procedure_Call (Assoc);
+   end Gen_Signal_Force_Non_Composite;
+
+   procedure Gen_Signal_Force is new Foreach_Non_Composite
+     (Data_Type => O_Enode,
+      Composite_Data_Type => Mnode,
+      Do_Non_Composite => Gen_Signal_Force_Non_Composite,
+      Prepare_Data_Array => Gen_Oenode_Prepare_Data_Composite,
+      Update_Data_Array => Gen_Oenode_Update_Data_Array,
+      Finish_Data_Array => Gen_Oenode_Finish_Data_Composite,
+      Prepare_Data_Record => Gen_Oenode_Prepare_Data_Composite,
+      Update_Data_Record => Gen_Oenode_Update_Data_Record,
+      Finish_Data_Record => Gen_Oenode_Finish_Data_Composite);
+
+   procedure Translate_Signal_Force_Assignment_Statement (Stmt : Iir)
+   is
+      Target : constant Iir := Get_Target (Stmt);
+      Target_Type : constant Iir := Get_Type (Target);
+      Targ_Tinfo : constant Type_Info_Acc := Get_Info (Target_Type);
+      Expr : constant Iir := Get_Expression (Stmt);
+      Value : Mnode;
+      Targ  : Mnode;
+   begin
+      Targ := Chap6.Translate_Name (Target, Mode_Signal);
+      Value := Chap7.Translate_Expression (Expr, Target_Type);
+
+      if Is_Composite (Targ_Tinfo)
+        and then Get_Constraint_State (Target_Type) /= Fully_Constrained
+      then
+         Stabilize (Targ);
+         Stabilize (Value);
+         Chap3.Check_Composite_Match
+           (Target_Type, Targ, Get_Type (Expr), Value, Stmt);
+      end if;
+
+      Signal_Force_Stmt := Stmt;
+      Gen_Signal_Force (Targ, Target_Type, M2E (Value));
+   end Translate_Signal_Force_Assignment_Statement;
+
+   procedure Translate_Statement (Stmt : Iir) is
    begin
       New_Debug_Line_Stmt (Get_Line_Number (Stmt));
       Open_Temp;
@@ -4895,6 +5018,10 @@ package body Trans.Chap8 is
                Trans.Update_Node_Infos;
                Translate_If_Statement (C_Stmt);
             end;
+         when Iir_Kind_Signal_Release_Assignment_Statement =>
+            Translate_Signal_Release_Assignment_Statement (Stmt);
+         when Iir_Kind_Signal_Force_Assignment_Statement =>
+            Translate_Signal_Force_Assignment_Statement (Stmt);
 
          when Iir_Kind_Null_Statement =>
             --  A null statement is translated to a NOP, so that the
diff --git a/src/vhdl/translate/trans_decls.ads b/src/vhdl/translate/trans_decls.ads
index 2f52b6035..0f0f3dd72 100644
--- a/src/vhdl/translate/trans_decls.ads
+++ b/src/vhdl/translate/trans_decls.ads
@@ -80,6 +80,9 @@ package Trans_Decls is
    Ghdl_Signal_Start_Assign_Null : O_Dnode;
    Ghdl_Signal_Next_Assign_Null : O_Dnode;
 
+   Ghdl_Signal_Release_Eff : O_Dnode;
+   Ghdl_Signal_Release_Drv : O_Dnode;
+
    Ghdl_Create_Signal_B1 : O_Dnode;
    Ghdl_Signal_Simple_Assign_B1 : O_Dnode;
    Ghdl_Signal_Start_Assign_B1 : O_Dnode;
@@ -88,6 +91,8 @@ package Trans_Decls is
    Ghdl_Signal_Add_Port_Driver_B1 : O_Dnode;
    Ghdl_Signal_Init_B1 : O_Dnode;
    Ghdl_Signal_Driving_Value_B1 : O_Dnode;
+   Ghdl_Signal_Force_Eff_B1 : O_Dnode;
+   Ghdl_Signal_Force_Drv_B1 : O_Dnode;
 
    Ghdl_Create_Signal_E8 : O_Dnode;
    Ghdl_Signal_Simple_Assign_E8 : O_Dnode;
@@ -97,6 +102,8 @@ package Trans_Decls is
    Ghdl_Signal_Add_Port_Driver_E8 : O_Dnode;
    Ghdl_Signal_Init_E8 : O_Dnode;
    Ghdl_Signal_Driving_Value_E8 : O_Dnode;
+   Ghdl_Signal_Force_Eff_E8 : O_Dnode;
+   Ghdl_Signal_Force_Drv_E8 : O_Dnode;
 
    Ghdl_Create_Signal_E32 : O_Dnode;
    Ghdl_Signal_Simple_Assign_E32 : O_Dnode;
@@ -106,6 +113,8 @@ package Trans_Decls is
    Ghdl_Signal_Add_Port_Driver_E32 : O_Dnode;
    Ghdl_Signal_Init_E32 : O_Dnode;
    Ghdl_Signal_Driving_Value_E32 : O_Dnode;
+   Ghdl_Signal_Force_Eff_E32 : O_Dnode;
+   Ghdl_Signal_Force_Drv_E32 : O_Dnode;
 
    Ghdl_Create_Signal_I32 : O_Dnode;
    Ghdl_Signal_Simple_Assign_I32 : O_Dnode;
@@ -115,6 +124,8 @@ package Trans_Decls is
    Ghdl_Signal_Add_Port_Driver_I32 : O_Dnode;
    Ghdl_Signal_Init_I32 : O_Dnode;
    Ghdl_Signal_Driving_Value_I32 : O_Dnode;
+   Ghdl_Signal_Force_Eff_I32 : O_Dnode;
+   Ghdl_Signal_Force_Drv_I32 : O_Dnode;
 
    Ghdl_Create_Signal_F64 : O_Dnode;
    Ghdl_Signal_Simple_Assign_F64 : O_Dnode;
@@ -124,6 +135,8 @@ package Trans_Decls is
    Ghdl_Signal_Add_Port_Driver_F64 : O_Dnode;
    Ghdl_Signal_Init_F64 : O_Dnode;
    Ghdl_Signal_Driving_Value_F64 : O_Dnode;
+   Ghdl_Signal_Force_Eff_F64 : O_Dnode;
+   Ghdl_Signal_Force_Drv_F64 : O_Dnode;
 
    Ghdl_Create_Signal_I64 : O_Dnode;
    Ghdl_Signal_Simple_Assign_I64 : O_Dnode;
@@ -133,6 +146,8 @@ package Trans_Decls is
    Ghdl_Signal_Add_Port_Driver_I64 : O_Dnode;
    Ghdl_Signal_Init_I64 : O_Dnode;
    Ghdl_Signal_Driving_Value_I64 : O_Dnode;
+   Ghdl_Signal_Force_Eff_I64 : O_Dnode;
+   Ghdl_Signal_Force_Drv_I64 : O_Dnode;
 
    Ghdl_Signal_In_Conversion : O_Dnode;
    Ghdl_Signal_Out_Conversion : O_Dnode;
diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb
index b510a7ae5..165f57d43 100644
--- a/src/vhdl/translate/translation.adb
+++ b/src/vhdl/translate/translation.adb
@@ -809,17 +809,18 @@ package body Translation is
       Finish_Subprogram_Decl (Interfaces, Ghdl_Finalize_Register);
    end Initialize;
 
-   procedure Create_Signal_Subprograms
-     (Suffix : String;
-      Val_Type : O_Tnode;
-      Create_Signal : out O_Dnode;
-      Init_Signal : out O_Dnode;
-      Simple_Assign : out O_Dnode;
-      Start_Assign : out O_Dnode;
-      Next_Assign : out O_Dnode;
-      Associate_Value : out O_Dnode;
-      Add_Port_Driver : out O_Dnode;
-      Driving_Value : out O_Dnode)
+   procedure Create_Signal_Subprograms (Suffix          : String;
+                                        Val_Type        : O_Tnode;
+                                        Create_Signal   : out O_Dnode;
+                                        Init_Signal     : out O_Dnode;
+                                        Simple_Assign   : out O_Dnode;
+                                        Start_Assign    : out O_Dnode;
+                                        Next_Assign     : out O_Dnode;
+                                        Associate_Value : out O_Dnode;
+                                        Add_Port_Driver : out O_Dnode;
+                                        Driving_Value   : out O_Dnode;
+                                        Force_Drv       : out O_Dnode;
+                                        Force_Eff       : out O_Dnode)
    is
       Interfaces : O_Inter_List;
       Param : O_Dnode;
@@ -910,6 +911,24 @@ package body Translation is
          O_Storage_External, Val_Type);
       New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
       Finish_Subprogram_Decl (Interfaces, Driving_Value);
+
+      --  procedure __ghdl_signal_force_drv_XXX (sign : __ghdl_signal_ptr;
+      --                                         val : VAL_TYPE);
+      Start_Procedure_Decl
+        (Interfaces, Get_Identifier ("__ghdl_signal_force_drv_" & Suffix),
+         O_Storage_External);
+      New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+      New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type);
+      Finish_Subprogram_Decl (Interfaces, Force_Drv);
+
+      --  procedure __ghdl_signal_force_eff_XXX (sign : __ghdl_signal_ptr;
+      --                                         val : VAL_TYPE);
+      Start_Procedure_Decl
+        (Interfaces, Get_Identifier ("__ghdl_signal_force_eff_" & Suffix),
+         O_Storage_External);
+      New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+      New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type);
+      Finish_Subprogram_Decl (Interfaces, Force_Eff);
    end Create_Signal_Subprograms;
 
    --  procedure __ghdl_image_NAME (res : std_string_ptr_node;
@@ -1574,7 +1593,9 @@ package body Translation is
                                  Ghdl_Signal_Next_Assign_E8,
                                  Ghdl_Signal_Associate_E8,
                                  Ghdl_Signal_Add_Port_Driver_E8,
-                                 Ghdl_Signal_Driving_Value_E8);
+                                 Ghdl_Signal_Driving_Value_E8,
+                                 Ghdl_Signal_Force_Drv_E8,
+                                 Ghdl_Signal_Force_Eff_E8);
 
       --  function __ghdl_create_signal_e32 (init_val : ghdl_i32_type)
       --                                     return __ghdl_signal_ptr;
@@ -1588,7 +1609,9 @@ package body Translation is
                                  Ghdl_Signal_Next_Assign_E32,
                                  Ghdl_Signal_Associate_E32,
                                  Ghdl_Signal_Add_Port_Driver_E32,
-                                 Ghdl_Signal_Driving_Value_E32);
+                                 Ghdl_Signal_Driving_Value_E32,
+                                 Ghdl_Signal_Force_Drv_E32,
+                                 Ghdl_Signal_Force_Eff_E32);
 
       --  function __ghdl_create_signal_b1 (init_val : ghdl_bool_type)
       --                                    return __ghdl_signal_ptr;
@@ -1602,7 +1625,9 @@ package body Translation is
                                  Ghdl_Signal_Next_Assign_B1,
                                  Ghdl_Signal_Associate_B1,
                                  Ghdl_Signal_Add_Port_Driver_B1,
-                                 Ghdl_Signal_Driving_Value_B1);
+                                 Ghdl_Signal_Driving_Value_B1,
+                                 Ghdl_Signal_Force_Drv_B1,
+                                 Ghdl_Signal_Force_Eff_B1);
 
       Create_Signal_Subprograms ("i32", Ghdl_I32_Type,
                                  Ghdl_Create_Signal_I32,
@@ -1612,7 +1637,9 @@ package body Translation is
                                  Ghdl_Signal_Next_Assign_I32,
                                  Ghdl_Signal_Associate_I32,
                                  Ghdl_Signal_Add_Port_Driver_I32,
-                                 Ghdl_Signal_Driving_Value_I32);
+                                 Ghdl_Signal_Driving_Value_I32,
+                                 Ghdl_Signal_Force_Drv_I32,
+                                 Ghdl_Signal_Force_Eff_I32);
 
       Create_Signal_Subprograms ("f64", Ghdl_Real_Type,
                                  Ghdl_Create_Signal_F64,
@@ -1622,7 +1649,9 @@ package body Translation is
                                  Ghdl_Signal_Next_Assign_F64,
                                  Ghdl_Signal_Associate_F64,
                                  Ghdl_Signal_Add_Port_Driver_F64,
-                                 Ghdl_Signal_Driving_Value_F64);
+                                 Ghdl_Signal_Driving_Value_F64,
+                                 Ghdl_Signal_Force_Drv_F64,
+                                 Ghdl_Signal_Force_Eff_F64);
 
       Create_Signal_Subprograms ("i64", Ghdl_I64_Type,
                                  Ghdl_Create_Signal_I64,
@@ -1632,7 +1661,23 @@ package body Translation is
                                  Ghdl_Signal_Next_Assign_I64,
                                  Ghdl_Signal_Associate_I64,
                                  Ghdl_Signal_Add_Port_Driver_I64,
-                                 Ghdl_Signal_Driving_Value_I64);
+                                 Ghdl_Signal_Driving_Value_I64,
+                                 Ghdl_Signal_Force_Drv_I64,
+                                 Ghdl_Signal_Force_Eff_I64);
+
+      --  procedure __ghdl_signal_release_drv (sig : __ghdl_signal_ptr);
+      Start_Procedure_Decl
+        (Interfaces, Get_Identifier ("__ghdl_signal_release_drv"),
+         O_Storage_External);
+      New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+      Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Release_Drv);
+
+      --  procedure __ghdl_signal_release_eff (sig : __ghdl_signal_ptr);
+      Start_Procedure_Decl
+        (Interfaces, Get_Identifier ("__ghdl_signal_release_eff"),
+         O_Storage_External);
+      New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+      Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Release_Eff);
 
       --  procedure __ghdl_process_add_sensitivity (sig : __ghdl_signal_ptr);
       Start_Procedure_Decl