simul: handle force/release signal assignments

6 files changed, 221 insertions, 18 deletions

diff --git a/src/grt/grt-signals.adb b/src/grt/grt-signals.adb
index b81a86fd3..7ddb24891 100644
--- a/src/grt/grt-signals.adb
+++ b/src/grt/grt-signals.adb
@@ -2070,6 +2070,26 @@ package body Grt.Signals is
                                                    F64 => Val)));
    end Ghdl_Signal_Force_Effective_F64;
 
+   procedure Ghdl_Signal_Force_Driving_Any (Sig : Ghdl_Signal_Ptr;
+                                            Val : Value_Union) is
+   begin
+      Append_Force_Value (new Force_Value'(Kind => Force,
+                                           Mode => Force_Driving,
+                                           Next => null,
+                                           Sig => Sig,
+                                           Val => Val));
+   end Ghdl_Signal_Force_Driving_Any;
+
+   procedure Ghdl_Signal_Force_Effective_Any (Sig : Ghdl_Signal_Ptr;
+                                              Val : Value_Union) is
+   begin
+      Append_Force_Value (new Force_Value'(Kind => Force,
+                                           Mode => Force_Effective,
+                                           Next => null,
+                                           Sig => Sig,
+                                           Val => Val));
+   end Ghdl_Signal_Force_Effective_Any;
+
    --  Remove all (but Signal_End) signals in the next active chain.
    --  Called when a transaction/event will occur before the time for this
    --  chain.
@@ -3565,20 +3585,20 @@ package body Grt.Signals is
             if Trans /= null then
                Free (Sig.S.Drivers (0).First_Trans);
                Sig.S.Drivers (0).First_Trans := Trans;
-            end if;
 
-            --  Update driving value (unless forced)
-            if not Sig.Flags.Is_Drv_Forced then
-               case Trans.Kind is
-                  when Trans_Value =>
-                     Sig.Driving_Value := Trans.Val;
-                  when Trans_Direct =>
-                     Internal_Error ("update_signals: trans_direct");
-                  when Trans_Null =>
-                     Error ("null transaction");
-                  when Trans_Error =>
-                     Error_Trans_Error (Trans);
-               end case;
+               --  Update driving value (unless forced)
+               if not Sig.Flags.Is_Drv_Forced then
+                  case Trans.Kind is
+                     when Trans_Value =>
+                        Sig.Driving_Value := Trans.Val;
+                     when Trans_Direct =>
+                        Internal_Error ("update_signals: trans_direct");
+                     when Trans_Null =>
+                        Error ("null transaction");
+                     when Trans_Error =>
+                        Error_Trans_Error (Trans);
+                  end case;
+               end if;
             end if;
 
             if not Sig.Flags.Is_Eff_Forced then
diff --git a/src/grt/grt-signals.ads b/src/grt/grt-signals.ads
index 76977d37a..6014180be 100644
--- a/src/grt/grt-signals.ads
+++ b/src/grt/grt-signals.ads
@@ -614,6 +614,11 @@ package Grt.Signals is
    procedure Ghdl_Process_Add_Port_Driver
      (Sign : Ghdl_Signal_Ptr; Val : Value_Union);
 
+   procedure Ghdl_Signal_Force_Driving_Any (Sig : Ghdl_Signal_Ptr;
+                                            Val : Value_Union);
+   procedure Ghdl_Signal_Force_Effective_Any (Sig : Ghdl_Signal_Ptr;
+                                              Val : Value_Union);
+
    --  For B1
    function Ghdl_Create_Signal_B1 (Val_Ptr : Ghdl_Value_Ptr;
                                    Resolv_Func : Resolver_Acc;
diff --git a/src/simul/simul-vhdl_simul.adb b/src/simul/simul-vhdl_simul.adb
index 37fd14d69..df958a43c 100644
--- a/src/simul/simul-vhdl_simul.adb
+++ b/src/simul/simul-vhdl_simul.adb
@@ -297,6 +297,79 @@ package body Simul.Vhdl_Simul is
       end case;
    end Assign_Value_To_Signal;
 
+   type Force_Kind is (Force, Release);
+
+   procedure Force_Signal_Value (Target: Memtyp;
+                                 Kind : Force_Kind;
+                                 Mode : Iir_Force_Mode;
+                                 Val : Memtyp)
+   is
+      Sig : Ghdl_Signal_Ptr;
+   begin
+      case Target.Typ.Kind is
+         when Type_Logic
+           | Type_Bit
+           | Type_Discrete
+           | Type_Float =>
+            Sig := Read_Sig (Target.Mem);
+            case Kind is
+               when Force =>
+                  case Mode is
+                     when Iir_Force_In =>
+                        Ghdl_Signal_Force_Effective_Any
+                          (Sig, To_Ghdl_Value (Val));
+                     when Iir_Force_Out =>
+                        Ghdl_Signal_Force_Driving_Any
+                          (Sig, To_Ghdl_Value (Val));
+                  end case;
+               when Release =>
+                  case Mode is
+                     when Iir_Force_In =>
+                        Ghdl_Signal_Release_Eff (Sig);
+                     when Iir_Force_Out =>
+                        Ghdl_Signal_Release_Drv (Sig);
+                  end case;
+            end case;
+         when Type_Vector
+           | Type_Array =>
+            declare
+               Len : constant Uns32 := Target.Typ.Abound.Len;
+               El : constant Type_Acc := Target.Typ.Arr_El;
+               Smem : Memory_Ptr;
+            begin
+               pragma Assert (Val.Typ.Abound.Len = Len);
+               for I in 1 .. Len loop
+                  if Val.Mem = null then
+                     Smem := null;
+                  else
+                     Smem := Val.Mem + Size_Type (I - 1) * El.Sz;
+                  end if;
+                  Force_Signal_Value
+                    ((El, Sig_Index (Target.Mem, (Len - I) * El.W)),
+                     Kind, Mode, (Val.Typ.Arr_El, Smem));
+               end loop;
+            end;
+         when Type_Record =>
+            for I in Target.Typ.Rec.E'Range loop
+               declare
+                  E : Rec_El_Type renames Target.Typ.Rec.E (I);
+                  Smem : Memory_Ptr;
+               begin
+                  if Val.Mem = null then
+                     Smem := null;
+                  else
+                     Smem := Val.Mem + E.Offs.Mem_Off;
+                  end if;
+                  Force_Signal_Value
+                    ((E.Typ, Sig_Index (Target.Mem, E.Offs.Net_Off)),
+                     Kind, Mode, (E.Typ, Smem));
+               end;
+            end loop;
+         when others =>
+            raise Internal_Error;
+      end case;
+   end Force_Signal_Value;
+
    procedure Add_Source (Typ : Type_Acc; Sig : Memory_Ptr; Val : Memory_Ptr) is
    begin
       case Typ.Kind is
@@ -990,6 +1063,70 @@ package body Simul.Vhdl_Simul is
       end loop;
    end Execute_Waveform_Assignment;
 
+   procedure Execute_Force_Assignment (Inst : Synth_Instance_Acc;
+                                       Target : Target_Info;
+                                       Kind : Force_Kind;
+                                       Stmt : Node;
+                                       Expr : Node)
+   is
+      use Synth.Vhdl_Expr;
+      Mode : constant Iir_Force_Mode := Get_Force_Mode (Stmt);
+
+      procedure Execute_Force_Signal (Inst : Synth_Instance_Acc;
+                                      Target : Target_Info;
+                                      Val : Valtyp;
+                                      Loc : Node);
+
+      procedure Execute_Force_Aggregate_Signal is
+         new Assign_Aggregate (Execute_Force_Signal);
+
+      procedure Execute_Force_Signal (Inst : Synth_Instance_Acc;
+                                      Target : Target_Info;
+                                      Val : Valtyp;
+                                      Loc : Node)
+      is
+         Sig : Memtyp;
+         Mem : Memtyp;
+      begin
+         case Target.Kind is
+            when Target_Aggregate =>
+               Execute_Force_Aggregate_Signal
+                 (Inst, Target.Aggr, Target.Targ_Type, Val, Loc);
+
+            when Target_Simple =>
+               declare
+                  E : Signal_Entry renames
+                    Signals_Table.Table (Target.Obj.Val.S);
+               begin
+                  Sig := (Target.Targ_Type,
+                          Sig_Index (E.Sig, Target.Off.Net_Off));
+               end;
+
+               if Val /= No_Valtyp then
+                  Mem := Get_Value_Memtyp (Val);
+               else
+                  Mem := Null_Memtyp;
+               end if;
+               Force_Signal_Value (Sig, Kind, Mode, Mem);
+
+            when Target_Memory =>
+               raise Internal_Error;
+         end case;
+      end Execute_Force_Signal;
+
+      Val : Valtyp;
+   begin
+      if Expr /= Null_Node then
+         Val := Synth_Expression_With_Type (Inst, Expr, Target.Targ_Type);
+         Val := Synth_Subtype_Conversion
+           (Inst, Val, Target.Targ_Type, False, Expr);
+      else
+         Val := No_Valtyp;
+      end if;
+
+      Execute_Force_Signal (Inst, Target, Val, Stmt);
+   end Execute_Force_Assignment;
+
    procedure Disconnect_Signal (Sig : Memtyp)
    is
       S : Ghdl_Signal_Ptr;
@@ -1099,6 +1236,36 @@ package body Simul.Vhdl_Simul is
       Release_Expr_Pool (Marker);
    end Execute_Simple_Signal_Assignment;
 
+   procedure Execute_Signal_Force_Assignment (Inst : Synth_Instance_Acc;
+                                              Stmt : Node)
+   is
+      Target : constant Node := Get_Target (Stmt);
+      Marker : Mark_Type;
+      Info : Target_Info;
+   begin
+      Mark_Expr_Pool (Marker);
+      Info := Synth_Target (Inst, Target);
+
+      Execute_Force_Assignment
+        (Inst, Info, Force, Stmt, Get_Expression (Stmt));
+      Release_Expr_Pool (Marker);
+   end Execute_Signal_Force_Assignment;
+
+   procedure Execute_Signal_Release_Assignment (Inst : Synth_Instance_Acc;
+                                                Stmt : Node)
+   is
+      Target : constant Node := Get_Target (Stmt);
+      Marker : Mark_Type;
+      Info : Target_Info;
+   begin
+      Mark_Expr_Pool (Marker);
+      Info := Synth_Target (Inst, Target);
+
+      Execute_Force_Assignment
+        (Inst, Info, Release, Stmt, Null_Node);
+      Release_Expr_Pool (Marker);
+   end Execute_Signal_Release_Assignment;
+
    procedure Execute_Conditional_Signal_Assignment (Inst : Synth_Instance_Acc;
                                                     Stmt : Node;
                                                     Concurrent : Boolean)
@@ -1449,6 +1616,13 @@ package body Simul.Vhdl_Simul is
                Execute_Conditional_Signal_Assignment (Inst, Stmt, False);
                Next_Statement (Process, Stmt);
 
+            when Iir_Kind_Signal_Force_Assignment_Statement =>
+               Execute_Signal_Force_Assignment (Inst, Stmt);
+               Next_Statement (Process, Stmt);
+            when Iir_Kind_Signal_Release_Assignment_Statement =>
+               Execute_Signal_Release_Assignment (Inst, Stmt);
+               Next_Statement (Process, Stmt);
+
             when Iir_Kind_Wait_Statement =>
                --  The suspend state is executed instead.
                raise Internal_Error;
diff --git a/src/synth/elab-vhdl_annotations.adb b/src/synth/elab-vhdl_annotations.adb
index ad83e0645..d5eb0eb63 100644
--- a/src/synth/elab-vhdl_annotations.adb
+++ b/src/synth/elab-vhdl_annotations.adb
@@ -786,7 +786,9 @@ package body Elab.Vhdl_Annotations is
               | Iir_Kind_Selected_Waveform_Assignment_Statement
               | Iir_Kind_Conditional_Signal_Assignment_Statement
               | Iir_Kind_Variable_Assignment_Statement
-              | Iir_Kind_Conditional_Variable_Assignment_Statement =>
+              | Iir_Kind_Conditional_Variable_Assignment_Statement
+              | Iir_Kind_Signal_Force_Assignment_Statement
+              | Iir_Kind_Signal_Release_Assignment_Statement =>
                null;
             when Iir_Kind_Procedure_Call_Statement =>
                Annotate_Procedure_Call_Statement (Block_Info, Stmt);
diff --git a/src/vhdl/vhdl-canon.adb b/src/vhdl/vhdl-canon.adb
index 8e4bfd588..cad575929 100644
--- a/src/vhdl/vhdl-canon.adb
+++ b/src/vhdl/vhdl-canon.adb
@@ -1397,11 +1397,13 @@ package body Vhdl.Canon is
 
          case Get_Kind (Stmt) is
             when Iir_Kind_Simple_Signal_Assignment_Statement
-               | Iir_Kind_Conditional_Signal_Assignment_Statement =>
+               | Iir_Kind_Conditional_Signal_Assignment_Statement
+               | Iir_Kind_Signal_Force_Assignment_Statement
+               | Iir_Kind_Signal_Release_Assignment_Statement =>
                null;
 
             when Iir_Kind_Variable_Assignment_Statement
-              | Iir_Kind_Conditional_Variable_Assignment_Statement =>
+               | Iir_Kind_Conditional_Variable_Assignment_Statement =>
                null;
 
             when Iir_Kind_If_Statement =>
diff --git a/src/vhdl/vhdl-nodes.ads b/src/vhdl/vhdl-nodes.ads
index 2fa4d6aaf..f16d7302b 100644
--- a/src/vhdl/vhdl-nodes.ads
+++ b/src/vhdl/vhdl-nodes.ads
@@ -5345,8 +5345,8 @@ package Vhdl.Nodes is
 
    type Iir_Force_Mode is
      (
-      Iir_Force_In,
-      Iir_Force_Out
+      Iir_Force_In,  --  Effective
+      Iir_Force_Out  --  Driving
      );
 
    --  LRM93 2.7 (conformance rules).