Rework callbacks, support cocotb.

26 files changed, 1505 insertions, 494 deletions

diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb
index 535cb0ad3..75bc946a5 100644
--- a/src/grt/grt-avhpi.adb
+++ b/src/grt/grt-avhpi.adb
@@ -27,15 +27,21 @@ with Grt.Vstrings; use Grt.Vstrings;
 with Grt.Rtis_Utils; use Grt.Rtis_Utils;
 
 package body Grt.Avhpi is
-   procedure Get_Root_Inst (Res : out VhpiHandleT)
-   is
+   procedure Get_Root_Inst (Res : out VhpiHandleT) is
    begin
       Res := (Kind => VhpiRootInstK,
               Ctxt => Get_Top_Context);
    end Get_Root_Inst;
 
+   procedure Get_Root_Scope (Res : out VhpiHandleT) is
+   begin
+      Res := (Kind => AvhpiRootScopeK,
+              Ctxt => Null_Context);
+   end Get_Root_Scope;
+
    procedure Get_Package_Inst (Res : out VhpiHandleT) is
    begin
+      --  Ctxt is the list of instantiated packages.
       Res := (Kind => VhpiIteratorK,
               Ctxt => (Base => Null_Address,
                        Block => To_Ghdl_Rti_Access (Ghdl_Rti_Top'Address)),
@@ -63,8 +69,7 @@ package body Grt.Avhpi is
    procedure Vhpi_Iterator (Rel : VhpiOneToManyT;
                             Ref : VhpiHandleT;
                             Res : out VhpiHandleT;
-                            Error : out AvhpiErrorT)
-   is
+                            Error : out AvhpiErrorT) is
    begin
       --  Default value in case of success.
       Res := (Kind => VhpiIteratorK,
@@ -89,6 +94,14 @@ package body Grt.Avhpi is
                when VhpiCompInstStmtK =>
                   Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt);
                   return;
+               when AvhpiRootScopeK =>
+                  Res := (Kind => AvhpiRootScopeIteratorK,
+                          Ctxt => Ref.Ctxt,
+                          Rel => Rel,
+                          It_Cur => 0,
+                          It2 => 0,
+                          Max2 => 0);
+                  return;
                when others =>
                   null;
             end case;
@@ -337,6 +350,19 @@ package body Grt.Avhpi is
       end loop;
    end Vhpi_Scan_Internal_Regions;
 
+   procedure Vhpi_Scan_Root_Design (Iterator : in out VhpiHandleT;
+                                    Res : out VhpiHandleT;
+                                    Error : out AvhpiErrorT) is
+   begin
+      if Iterator.It_Cur = 0 then
+         Get_Root_Inst (Res);
+         Iterator.It_Cur := 1;
+         Error := AvhpiErrorOk;
+      else
+         Error := AvhpiErrorIteratorEnd;
+      end if;
+   end Vhpi_Scan_Root_Design;
+
    procedure Rti_To_Handle (Rti : Ghdl_Rti_Access;
                             Ctxt : Rti_Context;
                             Res : out VhpiHandleT)
@@ -475,49 +501,55 @@ package body Grt.Avhpi is
       Error := AvhpiErrorIteratorEnd;
    end Vhpi_Scan_Decls;
 
-   procedure Vhpi_Scan (Iterator : in out VhpiHandleT;
-                        Res : out VhpiHandleT;
-                        Error : out AvhpiErrorT)
+   procedure Vhpi_Scan_Pack_Insts (Iterator : in out VhpiHandleT;
+                                   Res : out VhpiHandleT;
+                                   Error : out AvhpiErrorT)
    is
+      Blk : Ghdl_Rtin_Block_Acc;
    begin
-      if Iterator.Kind = AvhpiNameIteratorK then
-         case Iterator.N_Type.Kind is
-            when Ghdl_Rtik_Subtype_Array =>
-               Vhpi_Scan_Indexed_Name (Iterator, Res, Error);
-            when others =>
-               Error := AvhpiErrorHandle;
-               Res := Null_Handle;
-         end case;
-         return;
-      elsif Iterator.Kind /= VhpiIteratorK then
-         Error := AvhpiErrorHandle;
-         Res := Null_Handle;
+      Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
+      if Iterator.It_Cur >= Blk.Nbr_Child then
+         Error := AvhpiErrorIteratorEnd;
          return;
       end if;
+      Res := (Kind => VhpiPackInstK,
+              Ctxt => (Base => Null_Address,
+                       Block => Blk.Children (Iterator.It_Cur)));
+      Iterator.It_Cur := Iterator.It_Cur + 1;
+      Error := AvhpiErrorOk;
+   end Vhpi_Scan_Pack_Insts;
 
-      case Iterator.Rel is
-         when VhpiPackInsts =>
-            declare
-               Blk : Ghdl_Rtin_Block_Acc;
-            begin
-               Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
-               if Iterator.It_Cur >= Blk.Nbr_Child then
-                  Error := AvhpiErrorIteratorEnd;
-                  return;
-               end if;
-               Res := (Kind => VhpiPackInstK,
-                       Ctxt => (Base => Null_Address,
-                                Block => Blk.Children (Iterator.It_Cur)));
-               Iterator.It_Cur := Iterator.It_Cur + 1;
-               Error := AvhpiErrorOk;
-            end;
-         when VhpiInternalRegions =>
-            Vhpi_Scan_Internal_Regions (Iterator, Res, Error);
-         when VhpiDecls =>
-            Vhpi_Scan_Decls (Iterator, Res, Error);
+   procedure Vhpi_Scan (Iterator : in out VhpiHandleT;
+                        Res : out VhpiHandleT;
+                        Error : out AvhpiErrorT)
+   is
+   begin
+      case Iterator.Kind is
+         when AvhpiNameIteratorK =>
+            case Iterator.N_Type.Kind is
+               when Ghdl_Rtik_Subtype_Array =>
+                  Vhpi_Scan_Indexed_Name (Iterator, Res, Error);
+               when others =>
+                  Error := AvhpiErrorHandle;
+                  Res := Null_Handle;
+            end case;
+         when VhpiIteratorK =>
+            case Iterator.Rel is
+               when VhpiPackInsts =>
+                  Vhpi_Scan_Pack_Insts (Iterator, Res, Error);
+               when VhpiInternalRegions =>
+                  Vhpi_Scan_Internal_Regions (Iterator, Res, Error);
+               when VhpiDecls =>
+                  Vhpi_Scan_Decls (Iterator, Res, Error);
+               when others =>
+                  Res := Null_Handle;
+                  Error := AvhpiErrorNotImplemented;
+            end case;
+         when AvhpiRootScopeIteratorK =>
+            Vhpi_Scan_Root_Design (Iterator, Res, Error);
          when others =>
+            Error := AvhpiErrorHandle;
             Res := Null_Handle;
-            Error := AvhpiErrorNotImplemented;
       end case;
    end Vhpi_Scan;
 
@@ -539,7 +571,9 @@ package body Grt.Avhpi is
             declare
                Blk : Ghdl_Rtin_Block_Acc;
             begin
+               --  Get top architecture.
                Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block);
+               --  From architecture to entity.
                Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
                return Blk.Name;
             end;
@@ -1240,5 +1274,3 @@ package body Grt.Avhpi is
       return AvhpiErrorOk;
    end Vhpi_Put_Value;
 end Grt.Avhpi;
-
-
diff --git a/src/grt/grt-avhpi.ads b/src/grt/grt-avhpi.ads
index b61b1ff8a..9609882e7 100644
--- a/src/grt/grt-avhpi.ads
+++ b/src/grt/grt-avhpi.ads
@@ -154,7 +154,11 @@ package Grt.Avhpi is
       VhpiWhileLoopK,
 
       --  Iterator, but on a name.
-      AvhpiNameIteratorK
+      AvhpiNameIteratorK,
+
+      --  Root scope that contains the top entity.  For vpi.
+      AvhpiRootScopeK,
+      AvhpiRootScopeIteratorK
      );
 
    type VhpiOneToOneT is
@@ -416,6 +420,9 @@ package Grt.Avhpi is
    --  Get the root instance.
    procedure Get_Root_Inst (Res : out VhpiHandleT);
 
+   --  For vpi: the scope that contains the root instance.
+   procedure Get_Root_Scope (Res : out VhpiHandleT);
+
    --  Get the instanciated packages.
    procedure Get_Package_Inst (Res : out VhpiHandleT);
 
@@ -522,7 +529,8 @@ private
       Ctxt : Rti_Context;
 
       case Kind is
-         when VhpiIteratorK =>
+         when VhpiIteratorK
+           | AvhpiRootScopeIteratorK =>
             Rel : VhpiOneToManyT;
             It_Cur : Ghdl_Index_Type;
             It2 : Ghdl_Index_Type;
diff --git a/src/grt/grt-callbacks.adb b/src/grt/grt-callbacks.adb
new file mode 100644
index 000000000..fba404834
--- /dev/null
+++ b/src/grt/grt-callbacks.adb
@@ -0,0 +1,207 @@
+--  GHDL Run Time (GRT) -  Callbacks.
+--  Copyright (C) 2015 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GCC; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+--
+--  As a special exception, if other files instantiate generics from this
+--  unit, or you link this unit with other files to produce an executable,
+--  this unit does not by itself cause the resulting executable to be
+--  covered by the GNU General Public License. This exception does not
+--  however invalidate any other reasons why the executable file might be
+--  covered by the GNU Public License.
+
+package body Grt.Callbacks is
+   Recycled_Handles : Callback_Handle := null;
+
+   procedure Free_Handle (Hand : Callback_Handle) is
+   begin
+      Hand.Next := Recycled_Handles;
+      Recycled_Handles := Hand;
+   end Free_Handle;
+
+   function Allocate_Handle return Callback_Handle
+   is
+      Res : Callback_Handle;
+   begin
+      Res := Recycled_Handles;
+      if Res = null then
+         return new Cb_Cell;
+      else
+         Recycled_Handles := Res.Next;
+         return Res;
+      end if;
+   end Allocate_Handle;
+
+   procedure Register_Callback_At
+     (List : in out Callback_Time_List;
+      Handle : out Callback_Handle;
+      T : Std_Time;
+      Proc : Callback_Acc;
+      Arg : System.Address := System.Null_Address)
+   is
+      Last, Cur : Callback_Handle;
+   begin
+      Handle := Allocate_Handle;
+      Handle.all := (T => T, Mode => Timed,
+                     Proc => Proc, Arg => Arg, Next => null);
+
+      Last := null;
+      Cur := List.First;
+
+      --  Insert after timeouts before (<=) T.
+      while Cur /= null loop
+         exit when Cur.T > T;
+         Last := Cur;
+         Cur := Cur.Next;
+      end loop;
+
+      if Last = null then
+         --  At head.
+         Handle.Next := List.First;
+         List.First := Handle;
+         List.First_Timeout := T;
+      else
+         pragma Assert (Cur = Last.Next);
+         Handle.Next := Cur;
+         Last.Next := Handle;
+      end if;
+   end Register_Callback_At;
+
+   procedure Call_Time_Callbacks (List : in out Callback_Time_List)
+   is
+      C : Callback_Handle;
+   begin
+      pragma Assert (List.First_Timeout = Current_Time);
+
+      loop
+         C := List.First;
+         if C = null then
+            --  No more callback.
+            List.First_Timeout := Std_Time'Last;
+            exit;
+         elsif C.T > Current_Time then
+            --  No more callbacks for current time.
+            List.First_Timeout := C.T;
+            exit;
+         end if;
+
+         List.First := C.Next;
+
+         --  Calling the callback may have side effects, like adding a new
+         --  callback.  They should be in the future.
+         declare
+            Proc : constant Callback_Acc := C.Proc;
+            Arg : constant System.Address := C.Arg;
+         begin
+            Free_Handle (C);
+            Proc.all (Arg);
+         end;
+      end loop;
+   end Call_Time_Callbacks;
+
+   procedure Register_Callback
+     (List : in out Callback_List;
+      Handle : out Callback_Handle;
+      Mode : Callback_Mode;
+      Proc : Callback_Acc;
+      Arg : System.Address := System.Null_Address) is
+   begin
+      Handle := Allocate_Handle;
+      Handle.all := (T => 0, Mode => Mode,
+                     Proc => Proc, Arg => Arg, Next => null);
+
+      --  Append.
+      if List.First = null then
+         pragma Assert (List.Last = null);
+         List.First := Handle;
+      else
+         pragma Assert (List.Last /= null);
+         List.Last.Next := Handle;
+      end if;
+      List.Last := Handle;
+   end Register_Callback;
+
+   procedure Call_Callbacks (List : in out Callback_List)
+   is
+      --  Last cell to call.  Newly appended cells are not executed.
+      Last : constant Callback_Handle := List.Last;
+
+      Cell, Next_Cell, Prev_Cell : Callback_Handle;
+   begin
+      Cell := List.First;
+
+      if Cell = null then
+         return;
+      end if;
+
+      Prev_Cell := null;
+      loop
+         --  First, call the callback.  This may change the queue (for example
+         --  append a new callback and therefore change the next link of that
+         --  cell).
+         declare
+            Proc : constant Callback_Acc := Cell.Proc;
+            Arg : constant System.Address := Cell.Arg;
+         begin
+            Proc.all (Arg);
+         end;
+
+         Next_Cell := Cell.Next;
+         if Cell.Mode = Oneshot then
+            if Prev_Cell = null then
+               --  First cell of the list, update head.
+               List.First := Next_Cell;
+            else
+               Prev_Cell.Next := Next_Cell;
+            end if;
+            if Next_Cell = null then
+               List.Last := Prev_Cell;
+            end if;
+            Free_Handle (Cell);
+         else
+            Prev_Cell := Cell;
+         end if;
+         exit when Cell = Last;
+         Cell := Next_Cell;
+      end loop;
+   end Call_Callbacks;
+
+   procedure Nop_Callback (Arg : System.Address) is
+   begin
+      null;
+   end Nop_Callback;
+
+   procedure Delete_Callback (Handle : Callback_Handle) is
+   begin
+      Handle.Proc := Nop_Callback'Access;
+
+      if Handle.Mode = Repeat then
+         --  Be sure the callback will be removed at the next call.
+         Handle.Mode := Oneshot;
+      end if;
+   end Delete_Callback;
+
+   function Get_First_Time (List : Callback_Time_List) return Std_Time is
+   begin
+      return List.First_Timeout;
+   end Get_First_Time;
+
+   function Has_Callbacks (List : Callback_List) return Boolean is
+   begin
+      return List.First /= null;
+   end Has_Callbacks;
+
+end Grt.Callbacks;
diff --git a/src/grt/grt-callbacks.ads b/src/grt/grt-callbacks.ads
new file mode 100644
index 000000000..05d01b3eb
--- /dev/null
+++ b/src/grt/grt-callbacks.ads
@@ -0,0 +1,107 @@
+--  GHDL Run Time (GRT) -  Callbacks.
+--  Copyright (C) 2015 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GCC; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+--
+--  As a special exception, if other files instantiate generics from this
+--  unit, or you link this unit with other files to produce an executable,
+--  this unit does not by itself cause the resulting executable to be
+--  covered by the GNU General Public License. This exception does not
+--  however invalidate any other reasons why the executable file might be
+--  covered by the GNU Public License.
+with System;
+with Grt.Types; use Grt.Types;
+
+--  Callbacks are user registered procedures that are called during simulation.
+--  They are used to implement vpi/vhpi callbacks, but also some features like
+--  vcd or fst.
+
+package Grt.Callbacks is
+   pragma Preelaborate (Grt.Callbacks);
+
+   --  It would be nice to use OOP (tagged types and overriding), but this is
+   --  not anymore available in the context of pragma No_Run_Time.
+   --  Furthermore, that wouldn't be that convenient because of lack of
+   --  multiple inheritance.
+   --
+   --  Thus the use of a 'generic' callback type.  The type Address is used for
+   --  any pointer type.
+   type Callback_Acc is access procedure (Arg : System.Address);
+
+   type Callback_Handle is private;
+
+   type Callback_List is limited private;
+   pragma Preelaborable_Initialization (Callback_List);
+
+   type Callback_Time_List is limited private;
+   pragma Preelaborable_Initialization (Callback_Time_List);
+
+   --  Register a timeout: PROC will be called with parameter ARG at time T
+   --  at the beginning of the cycle (before any process).  Insertion is O(n).
+   procedure Register_Callback_At
+     (List : in out Callback_Time_List;
+      Handle : out Callback_Handle;
+      T : Std_Time;
+      Proc : Callback_Acc;
+      Arg : System.Address := System.Null_Address);
+
+   type Callback_Mode is (Timed, Repeat, Oneshot);
+   subtype Callback_Non_Timed_Mode is Callback_Mode range Repeat .. Oneshot;
+
+   procedure Register_Callback
+     (List : in out Callback_List;
+      Handle : out Callback_Handle;
+      Mode : Callback_Mode;
+      Proc : Callback_Acc;
+      Arg : System.Address := System.Null_Address);
+
+   --  Delete callback.
+   --  In fact the callback is just marked as deleted, but will be removed
+   --  only at the point it would be called.
+   procedure Delete_Callback (Handle : Callback_Handle);
+
+   --  Call the callbacks.
+   procedure Call_Callbacks (List : in out Callback_List);
+   procedure Call_Time_Callbacks (List : in out Callback_Time_List);
+
+   --  Return the date of the earliest callbacks (or Std_Time'Last if none).
+   function Get_First_Time (List : Callback_Time_List) return Std_Time;
+   pragma Inline (Get_First_Time);
+
+   --  Return True if there is at least one callback in the list.
+   function Has_Callbacks (List : Callback_List) return Boolean;
+   pragma Inline (Has_Callbacks);
+private
+   type Cb_Cell;
+   type Callback_Handle is access Cb_Cell;
+
+   type Cb_Cell is record
+      T : Std_Time;
+      Mode : Callback_Mode;
+      Proc : Callback_Acc;
+      Arg : System.Address;
+      Next : Callback_Handle;
+   end record;
+
+   type Callback_List is limited record
+      First, Last : Callback_Handle := null;
+   end record;
+
+   type Callback_Time_List is limited record
+      First : Callback_Handle := null;
+      First_Timeout : Std_Time := Std_Time'Last;
+   end record;
+end Grt.Callbacks;
diff --git a/src/grt/grt-cvpi.c b/src/grt/grt-cvpi.c
index 51edd678f..3e427c551 100644
--- a/src/grt/grt-cvpi.c
+++ b/src/grt/grt-cvpi.c
@@ -28,15 +28,7 @@
 //-----------------------------------------------------------------------------
 // VPI callback functions
 typedef void *vpiHandle, *p_vpi_time, *p_vpi_value;
-typedef struct t_cb_data {
-      int reason;
-      int (*cb_rtn)(struct t_cb_data*cb);
-      vpiHandle obj;
-      p_vpi_time time;
-      p_vpi_value value;
-      int index;
-      char*user_data;
-} s_cb_data, *p_cb_data;
+typedef struct t_cb_data s_cb_data, *p_cb_data;
 
 //-----------------------------------------------------------------------------
 // vpi thunking a la Icarus Verilog
@@ -103,7 +95,7 @@ typedef struct {
 
 int vpi_register_sim(p_vpi_thunk tp);
 
-static vpi_thunk thunkTable = 
+static vpi_thunk thunkTable =
 {	VPI_THUNK_MAGIC,
 	vpi_register_systf,
 	vpi_vprintf,
@@ -128,8 +120,8 @@ static vpi_thunk thunkTable =
 	vpi_put_value,
 	vpi_free_object,
 	vpi_get_vlog_info,
-	0, //vpi_chk_error,
-	0 //vpi_handle_by_name
+	vpi_chk_error,
+	vpi_handle_by_name
 };
 
 //-----------------------------------------------------------------------------
@@ -202,7 +194,7 @@ loadVpiModule (const char* modulename)
       "vpi_register_sim"        // w/o  leading underscore: Linux
     };
 
-  int i;	
+  int i;
   void* vpimod;
 
   fprintf (stderr, "loading VPI module '%s'\n", modulename);
@@ -223,15 +215,15 @@ loadVpiModule (const char* modulename)
     {
       void* vpithunk;
       void* vpitable;
-	  
+
       vpitable = module_symbol (vpimod, vpitablenames[i]);
       vpithunk = module_symbol (vpimod, vpithunknames[i]);
-	  
+
       if (vpithunk)
 	{
 	  typedef int (*funT)(p_vpi_thunk tp);
 	  funT regsim;
-	  
+
 	  regsim = (funT)vpithunk;
 	  regsim (&thunkTable);
 	}
@@ -240,20 +232,20 @@ loadVpiModule (const char* modulename)
 	  // this is not an error, as the register-mechanism
 	  // is not standardized
 	}
-      
+
       if (vpitable)
 	{
 	  unsigned int tmp;
 	  //extern void (*vlog_startup_routines[])();
 	  typedef void (*vlog_startup_routines_t)(void);
 	  vlog_startup_routines_t *vpifuns;
-				
+
 	  vpifuns = (vlog_startup_routines_t*)vpitable;
 	  for (tmp = 0; vpifuns[tmp]; tmp++)
 	    {
 	      vpifuns[tmp]();
 	    }
-	  
+
 	  fprintf (stderr, "VPI module loaded!\n");
 	  return 0; // successfully registered VPI module
 	}
@@ -274,4 +266,3 @@ vpi_printf (const char *fmt, ...)
 
 //-----------------------------------------------------------------------------
 // end of file
-
diff --git a/src/grt/grt-disp_signals.adb b/src/grt/grt-disp_signals.adb
index ebb249954..684a4548c 100644
--- a/src/grt/grt-disp_signals.adb
+++ b/src/grt/grt-disp_signals.adb
@@ -425,7 +425,7 @@ package body Grt.Disp_Signals is
          if Sig.S.Mode_Sig in Mode_Signal_User then
             Put (" #drv: ");
             Put_I32 (stdout, Ghdl_I32 (Sig.S.Nbr_Drivers));
-            case Sig.Sig_Kind is
+            case Sig.Flags.Sig_Kind is
                when Kind_Signal_No =>
                   Put ("  ");
                when Kind_Signal_Register =>
@@ -460,6 +460,7 @@ package body Grt.Disp_Signals is
    procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr)
    is
    begin
+      Put_Signal_Name (stdout, Sig);
       Disp_Simple_Signal (Sig, null, True);
    end Disp_A_Signal;
 
diff --git a/src/grt/grt-errors.adb b/src/grt/grt-errors.adb
index 66dfbf1dd..62ee86e2e 100644
--- a/src/grt/grt-errors.adb
+++ b/src/grt/grt-errors.adb
@@ -48,8 +48,7 @@ package body Grt.Errors is
 
    procedure Exit_Simulation is
    begin
-      --  -2 is Grt.Errors.Run_Stop
-      Maybe_Return_Via_Longjump (-2);
+      Maybe_Return_Via_Longjump (Run_Stop);
       Internal_Error ("exit_simulation");
    end Exit_Simulation;
 
diff --git a/src/grt/grt-errors.ads b/src/grt/grt-errors.ads
index 833cded1b..bb7aab9a4 100644
--- a/src/grt/grt-errors.ads
+++ b/src/grt/grt-errors.ads
@@ -79,6 +79,18 @@ package Grt.Errors is
    Exit_Status : Integer := 0;
    procedure Exit_Simulation;
 
+   --  Simulation status,
+   --  Runtime error.
+   Run_Error : constant Integer := -1;
+   --  No process has been run.
+   Run_None : constant Integer := 1;
+   --  At least one process was run.
+   Run_Resumed : constant Integer := 2;
+   --  Simulation is finished.
+   Run_Finished : constant Integer := 3;
+   --  Stop/finish request from user (via std.env).
+   Run_Stop : constant Integer := 4;
+
    --  Hook called in case of error.
    Error_Hook : Grt.Hooks.Proc_Hook_Type := null;
 
@@ -89,4 +101,3 @@ private
    pragma Export (C, Grt_Overflow_Error, "grt_overflow_error");
    pragma Export (C, Grt_Null_Access_Error, "grt_null_access_error");
 end Grt.Errors;
-
diff --git a/src/grt/grt-fst.adb b/src/grt/grt-fst.adb
index 62926688f..a87a4e1ef 100644
--- a/src/grt/grt-fst.adb
+++ b/src/grt/grt-fst.adb
@@ -635,9 +635,9 @@ package body Grt.Fst is
    procedure Fst_Cycle is
    begin
       --  Disp values.
-      fstWriterEmitTimeChange (Context, Unsigned_64 (Cycle_Time));
+      fstWriterEmitTimeChange (Context, Unsigned_64 (Current_Time));
 
-      if Cycle_Time = 0 then
+      if Current_Time = 0 then
          --  Disp all values.
          for I in Fst_Table.First .. Fst_Table.Last loop
             Fst_Put_Var (I);
@@ -645,7 +645,8 @@ package body Grt.Fst is
       else
          --  Disp only values changed.
          for I in Fst_Table.First .. Fst_Table.Last loop
-            if Verilog_Wire_Changed (Fst_Table.Table (I).Wire, Cycle_Time) then
+            if Verilog_Wire_Changed (Fst_Table.Table (I).Wire, Current_Time)
+            then
                Fst_Put_Var (I);
             end if;
          end loop;
diff --git a/src/grt/grt-hooks.adb b/src/grt/grt-hooks.adb
index 44a9b7a41..991a3a3d6 100644
--- a/src/grt/grt-hooks.adb
+++ b/src/grt/grt-hooks.adb
@@ -195,5 +195,3 @@ package body Grt.Hooks is
       return False;
    end Has_Feature;
 end Grt.Hooks;
-
-
diff --git a/src/grt/grt-hooks.ads b/src/grt/grt-hooks.ads
index 12439088d..576ab4823 100644
--- a/src/grt/grt-hooks.ads
+++ b/src/grt/grt-hooks.ads
@@ -22,6 +22,8 @@
 --  covered by the GNU General Public License. This exception does not
 --  however invalidate any other reasons why the executable file might be
 --  covered by the GNU Public License.
+with Grt.Callbacks;
+
 package Grt.Hooks is
    pragma Preelaborate (Grt.Hooks);
 
@@ -81,4 +83,24 @@ package Grt.Hooks is
 
    --  Nil procedure.
    procedure Proc_Hook_Nil;
+
+   --  Callbacks.
+
+   --  Called at the beginning of the cycle at time T.
+   Cb_After_Delay : Callbacks.Callback_Time_List;
+
+   --  Called at the beginning of a non-delta cycle.
+   Cb_Next_Time_Step : Callbacks.Callback_List;
+
+   --  Called after updating the signals.  For value change detection.
+   Cb_Signals_Updated : Callbacks.Callback_List;
+
+   --  Called at the last known delta cycle of a timestep, before execution
+   --  of postponed processes.
+   --  The callback may change signals and therefore generating new delta
+   --  cycle.
+   Cb_Last_Known_Delta : Callbacks.Callback_List;
+
+   Cb_End_Of_Time_Step : Callbacks.Callback_List;
+
 end Grt.Hooks;
diff --git a/src/grt/grt-main.adb b/src/grt/grt-main.adb
index 743e4b306..4b2614aad 100644
--- a/src/grt/grt-main.adb
+++ b/src/grt/grt-main.adb
@@ -178,10 +178,6 @@ package body Grt.Main is
          Disp_Stats_Hook (0);
       end if;
 
-      if Status = -2 then
-         return;
-      end if;
-
       if Expect_Failure then
          if Status >= 0 then
             Expect_Failure := False;
diff --git a/src/grt/grt-options.adb b/src/grt/grt-options.adb
index a03b6bea3..806d77479 100644
--- a/src/grt/grt-options.adb
+++ b/src/grt/grt-options.adb
@@ -22,10 +22,12 @@
 --  covered by the GNU General Public License. This exception does not
 --  however invalidate any other reasons why the executable file might be
 --  covered by the GNU Public License.
+with System;
 with Interfaces; use Interfaces;
 with Grt.Errors; use Grt.Errors;
 with Grt.Astdio;
 with Grt.Hooks;
+with Grt.Callbacks;
 
 package body Grt.Options is
 
@@ -54,8 +56,7 @@ package body Grt.Options is
    pragma Export (C, Std_Standard_Time_Hr, "std__standard__time__BT__hr");
    pragma Weak_External (Std_Standard_Time_Hr);
 
-   procedure Set_Time_Resolution (Res : Character)
-   is
+   procedure Set_Time_Resolution (Res : Character) is
    begin
       Std_Standard_Time_Hr := 0;
       case Res is
@@ -220,6 +221,16 @@ package body Grt.Options is
       end if;
    end To_Lower;
 
+   Stop_Time : Std_Time := Std_Time'First;
+
+   procedure Stop_Time_Callback (Arg : System.Address)
+   is
+      pragma Unreferenced (Arg);
+   begin
+      Break_Simulation := True;
+      Info ("simulation stopped by --stop-time");
+   end Stop_Time_Callback;
+
    procedure Decode_Option
      (Option : String; Status : out Decode_Option_Status)
    is
@@ -308,7 +319,7 @@ package body Grt.Options is
                if Flag_String (5) = '-' then
                   Error ("time resolution is ignored");
                elsif Flag_String (5) = '?' then
-                  if Stop_Time /= Std_Time'Last then
+                  if Stop_Time /= Std_Time'First then
                      Error ("time resolution must be set "
                               & "before --stop-time");
                   else
@@ -519,5 +530,16 @@ package body Grt.Options is
             end case;
          end;
       end loop;
+
+      if Stop_Time /= Std_Time'First then
+         declare
+            use Callbacks;
+            Stop_Handle : Callback_Handle;
+         begin
+            Register_Callback_At
+              (Hooks.Cb_After_Delay, Stop_Handle,
+               Stop_Time, Stop_Time_Callback'Access);
+         end;
+      end if;
    end Decode;
 end Grt.Options;
diff --git a/src/grt/grt-options.ads b/src/grt/grt-options.ads
index 44a85b6eb..604952e20 100644
--- a/src/grt/grt-options.ads
+++ b/src/grt/grt-options.ads
@@ -118,10 +118,6 @@ package Grt.Options is
    --  Handling of assertions from IEEE library.
    Ieee_Asserts : Assert_Handling := Enable_Asserts;
 
-   --  Set by --stop-time=XXX to stop the simulation at or just after XXX.
-   --  (unit is fs in fact).
-   Stop_Time : Std_Time := Std_Time'Last;
-
    --  Set by --stop-delta=XXX to stop the simulation after XXX delta cycles.
    Stop_Delta : Natural := 5000;
 
@@ -132,6 +128,9 @@ package Grt.Options is
    type Activity_Mode is (Activity_All, Activity_Minimal, Activity_None);
    Flag_Activity : Activity_Mode := Activity_Minimal;
 
+   --  If true, the simulation should be stopped.
+   Break_Simulation : Boolean;
+
    --  Set by --thread=
    --  Number of threads used to do the simulation.
    --  1 mean no additionnal threads, 0 means as many threads as number of
diff --git a/src/grt/grt-processes.adb b/src/grt/grt-processes.adb
index 748ab6dd9..feb312337 100644
--- a/src/grt/grt-processes.adb
+++ b/src/grt/grt-processes.adb
@@ -33,6 +33,7 @@ with Grt.Options;
 with Grt.Rtis_Addr; use Grt.Rtis_Addr;
 with Grt.Rtis_Utils;
 with Grt.Hooks;
+with Grt.Callbacks; use Grt.Callbacks;
 with Grt.Disp_Signals;
 with Grt.Stats;
 with Grt.Threads; use Grt.Threads;
@@ -316,12 +317,12 @@ package body Grt.Processes is
    --  List of unused action_list to be recycled.
    Old_Action_List : Action_List_Acc;
 
-
    procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr)
    is
       Proc : constant Process_Acc := Get_Current_Process;
       El : Action_List_Acc;
    begin
+      --  Allocate a structure.
       if Old_Action_List = null then
          El := new Action_List (Dynamic => True);
       else
@@ -620,21 +621,23 @@ package body Grt.Processes is
       --     1) TIME'HIGH
       Res := Std_Time'Last;
 
-      --     2) The next time at which a driver becomes active, or
-      Res := Std_Time'Min (Res, Grt.Signals.Find_Next_Time);
+      --     3) The next time at which a process resumes.
+      Res := Std_Time'Min (Res, Process_First_Timeout);
+
+      --  LRM08 14.7.5.1 Model execution
+      --    d) The next time at which a registered and enabled vhpiCbAfterDelay
+      --    [...] callback is to occur.
+      Res := Std_Time'Min (Res, Get_First_Time (Hooks.Cb_After_Delay));
 
       if Res = Current_Time then
          return Res;
       end if;
 
-      --     3) The next time at which a process resumes.
-      if Process_First_Timeout < Res then
-         --  No signals to be updated.
-         Grt.Signals.Flush_Active_List;
-
-         Res := Process_First_Timeout;
-      end if;
+      --     2) The next time at which a driver becomes active, or [...]
+      Res := Grt.Signals.Find_Next_Time (Res);
 
+      --  Note that Find_Next_Time has a side effect: it updates the
+      --  active_chain.  That's the reason why it is the last.
       return Res;
    end Compute_Next_Time;
 
@@ -688,16 +691,6 @@ package body Grt.Processes is
    --  Run resumed processes.
    --  If POSTPONED is true, resume postponed processes, else resume
    --  non-posponed processes.
-   --  Returns one of these values:
-   --  No process has been run.
-   Run_None : constant Integer := 1;
-   --  At least one process was run.
-   Run_Resumed : constant Integer := 2;
-   --  Simulation is finished.
-   Run_Finished : constant Integer := 3;
-   --  Stop/finish request from user (via std.env).
-   Run_Stop : constant Integer := -2;
-   pragma Unreferenced (Run_Stop);
 
    Mt_Last : Natural;
    Mt_Table : Process_Acc_Array_Acc;
@@ -736,7 +729,7 @@ package body Grt.Processes is
       end loop;
    end Run_Processes_Threads;
 
-   function Run_Processes (Postponed : Boolean) return Natural
+   function Run_Processes (Postponed : Boolean) return Integer
    is
       Table : Process_Acc_Array_Acc;
       Last : Natural;
@@ -795,9 +788,13 @@ package body Grt.Processes is
       end if;
    end Run_Processes;
 
+   --  Updated by Initialization_Phase and Simulation_Cycle to the time of the
+   --  next cycle.  Unchanged in case of delta-cycle.
+   Next_Time : Std_Time;
+
    procedure Initialization_Phase
    is
-      Status : Natural;
+      Status : Integer;
       pragma Unreferenced (Status);
    begin
       --  Allocate processes arrays.
@@ -843,7 +840,10 @@ package body Grt.Processes is
       --  - The time of the next simulation cycle (which in this case is the
       --    first simulation cycle), Tn, is calculated according to the rules
       --    of step f of the simulation cycle, below.
-      Current_Time := Compute_Next_Time;
+      Next_Time := Compute_Next_Time;
+      if Next_Time /= 0 then
+         Update_Active_Chain;
+      end if;
 
       --  Clear current_delta, will be set by Simulation_Cycle.
       Current_Delta := 0;
@@ -856,7 +856,7 @@ package body Grt.Processes is
       Tn : Std_Time;
       Status : Integer;
    begin
-      --  LRM93 12.6.4
+      --  LRM08 14.7.5.3 Simulation cycle (ex LRM93 12.6.4)
       --  A simulation cycle consists of the following steps:
       --
       --  a) The current time, Tc is set equal to Tn.  Simulation is complete
@@ -865,22 +865,53 @@ package body Grt.Processes is
       --  GHDL: this is done at the last step of the cycle.
       null;
 
-      --  b) Each active explicit signal in the model is updated.  (Events
-      --     may occur on signals as a result).
-      --  c) Each implicit signal in the model is updated.  (Events may occur
-      --     on signals as a result.)
+      --  b) The following actions occur in the indicated order:
+      --     1) If the current simulation cycle is not a delta cycle, each
+      --        registered and enabled vhpiCbNextTimeStep and
+      --        vhpiCbRepNextTimeStep callback is executed [TODO]
+      if Current_Delta = 0 then
+         Call_Callbacks (Hooks.Cb_Next_Time_Step);
+      end if;
+
+      --     2) Each registered and enabled vhpiCbStartOfNextCycle and
+      --        vhpiCbRepStartOfNextCycle callback is executed [TODO]
+      --     3) Each registered and enabled vhpiCbAfterDelay and
+      --        vhpiCbRepAfterDelay callback is executed.
+      if Current_Time = Get_First_Time (Hooks.Cb_After_Delay) then
+         Call_Time_Callbacks (Hooks.Cb_After_Delay);
+         if Options.Break_Simulation then
+            return Run_Stop;
+         end if;
+      end if;
+
+      --  c) Each active driver in the model is updated.  If a force or deposit
+      --     was scheduled for any driver, the force or deposit is no longer
+      --     scheduler for the driver [TODO]
+      --  d) Each signal on each net in the model that includes active drivers
+      --     is updated in an order that is consistent with the dependency
+      --     relaction between signals (see 14.7.4).  (Events may occur on
+      --     signals as a results.) If a force, deposit, or release was
+      --     scheduled for any signal, the force, deposit, or release is no
+      --     longer scheduled for the signal.
       if Options.Flag_Stats then
          Stats.Start_Update;
       end if;
       Update_Signals;
+      Call_Callbacks (Hooks.Cb_Signals_Updated);
       if Options.Flag_Stats then
          Stats.Start_Resume;
       end if;
 
-      --  d) For each process P, if P is currently sensitive to a signal S and
-      --     if an event has occured on S in this simulation cycle, then P
-      --     resumes.
+      --  e) Any action required to give effect to a PSL directive is performed
+      --     [TODO]
+      null;
+
+      --  f) The following actions occur in the indicated order:
+      --     2) For each process P, if P is currently sensitive to a signal S
+      --        and if an event has occured on S in this simulation cycle, then
+      --        P resumes.
       if Current_Time = Process_First_Timeout then
+         --  There are processes to awake.
          Tn := Last_Time;
          declare
             Proc : Process_Acc;
@@ -921,44 +952,61 @@ package body Grt.Processes is
          Process_First_Timeout := Tn;
       end if;
 
-      --  e) Each nonpostponed that has resumed in the current simulation cycle
-      --     is executed until it suspends.
+      --     3) For each nonpostponed that has resumed in the current
+      --        simulation cycle, the following actions occur in the indicated
+      --        order:
+      --        - Each registered and enabled vhpiCbResume callback associated
+      --          with P is executed [TODO]
+      --        - The processes executes until it suspends.
+      --        - Each registered and enabled vhpiCbSyspend callback associated
+      --          with P is executed [TODO]
       Status := Run_Processes (Postponed => False);
 
-      --  f) The time of the next simulation cycle, Tn, is determined by
-      --     setting it to the earliest of
-      --     1) TIME'HIGH
-      --     2) The next time at which a driver becomes active, or
-      --     3) The next time at which a process resumes.
-      --     If Tn = Tc, then the next simulation cycle (if any) will be a
-      --     delta cycle.
+      --  g) The time of the next simulation cycle, Tn, is calculated according
+      --    to the rules of 14.7.5.1
       if Options.Flag_Stats then
          Stats.Start_Next_Time;
       end if;
       Tn := Compute_Next_Time;
 
-      --  g) If the next simulation cycle will be a delta cycle, the remainder
-      --     of the step is skipped.
-      --     Otherwise, each postponed process that has resumed but has not
-      --     been executed since its last resumption is executed until it
-      --     suspends.  Then Tn is recalculated according to the rules of
-      --     step f.  It is an error if the execution of any postponed
-      --     process causes a delta cycle to occur immediatly after the
-      --     current simulation cycle.
-      if Tn = Current_Time then
-         if Current_Time = Last_Time and then Status = Run_None then
-            return Run_Finished;
-         else
-            Current_Delta := Current_Delta + 1;
-            return Run_Resumed;
+      --  h) If the next simulation cycle will be a delta cycle, the remainder
+      --     of the step is skipped. Otherwise the following actions occur
+      --     in the indicated order:
+      --     1) Each registered and enabled vhpiLastKnownDeltaCycle and
+      --        vhpiCbRepLastKnownDeltaCycle callback is executed. Tn is
+      --        recalculated according to the rules of 14.7.5.1
+      --     [...]
+      --     4) For each postponed process P, if P has resumed but has not been
+      --        executed since its last resumption, the following actions occur
+      --        in the indicated order:
+      --        - Each registered and enabled vhpiCbResume callback associated
+      --          with P is executed [TODO]
+      --        - The process executes until it suspends.
+      --        - Each registered and enabled vhpiCbSuspend callback associated
+      --          with P is executed [TODO]
+      --     5) Tn is recalculated according to the rules of 14.7.5.1
+      --     6) [TODO]
+      --     7) If Tn = TIME'HIGH and there are no active drivers, process
+      --        resumptions, or registered and enabled vhpiCbAfterDelay,
+      --        vhpiCbRepAfterDelay, vhpiCbTimeOut, or VhpiCbRepTimeOut
+      --        callbacks to occur at Tn, then each registered and enabled
+      --        vhpiCbQuiescence is executed. [TODO]
+      --        Tn is recalculated according to the rules of 14.7.5.1
+      --     It is an error if the execution of any postponed process or any
+      --     callback executed in substeps 3) through 7) of step h) causes a
+      --     delta cycle to occur immediatly after the current simulation
+      --     cycle.
+      if Tn /= Current_Time then
+         if Has_Callbacks (Hooks.Cb_Last_Known_Delta) then
+            Call_Callbacks (Hooks.Cb_Last_Known_Delta);
+            Flush_Active_Chain;
+            Tn := Compute_Next_Time;
          end if;
-      else
-         Current_Delta := 0;
-         if Nbr_Postponed_Processes /= 0 then
+      end if;
+      if Tn /= Current_Time then
+         if Last_Postponed_Resume_Process /= 0 then
+            Flush_Active_Chain;
             Status := Run_Processes (Postponed => True);
-         end if;
-         if Status = Run_Resumed then
-            Flush_Active_List;
             if Options.Flag_Stats then
                Stats.Start_Next_Time;
             end if;
@@ -967,15 +1015,27 @@ package body Grt.Processes is
                Error ("postponed process causes a delta cycle");
             end if;
          end if;
-         Current_Time := Tn;
+
+         Call_Callbacks (Hooks.Cb_End_Of_Time_Step);
+
+         Update_Active_Chain;
+         Next_Time := Tn;
+         Current_Delta := 0;
+         return Run_Resumed;
+      end if;
+
+      if Current_Time = Last_Time and then Status = Run_None then
+         --  End of time and no process to run.
+         return Run_Finished;
+      else
+         Current_Delta := Current_Delta + 1;
          return Run_Resumed;
       end if;
    end Simulation_Cycle;
 
-   function Simulation return Integer
+   procedure Simulation_Init
    is
       use Options;
-      Status : Integer;
    begin
       if Nbr_Threads /= 1 then
          Threads.Init;
@@ -993,20 +1053,29 @@ package body Grt.Processes is
          Grt.Disp_Signals.Disp_All_Signals;
       end if;
 
-      if Current_Time /= 0 then
+      if Next_Time /= 0 then
          --  This is the end of a cycle.  This can happen when the time is not
          --  zero after initialization.
-         Cycle_Time := 0;
          Grt.Hooks.Call_Cycle_Hooks;
       end if;
+   end Simulation_Init;
 
+   function Simulation_Main_Loop return Integer
+   is
+      use Options;
+      Status : Integer;
+   begin
       loop
-         Cycle_Time := Current_Time;
+         --  Update time.  This is the only place where Current_Time is
+         --  updated.
+         Current_Time := Next_Time;
          if Disp_Time then
             Grt.Disp.Disp_Now;
          end if;
+
          Status := Simulation_Cycle;
-         exit when Status < 0;
+         exit when Status = Run_Stop;
+
          if Trace_Signals then
             Grt.Disp_Signals.Disp_All_Signals;
          end if;
@@ -1027,14 +1096,15 @@ package body Grt.Processes is
             Error ("simulation stopped by --stop-delta");
             exit;
          end if;
-         if Current_Time > Stop_Time then
-            if Current_Time /= Last_Time then
-               Info ("simulation stopped by --stop-time");
-            end if;
-            exit;
-         end if;
       end loop;
 
+      return Status;
+   end Simulation_Main_Loop;
+
+   procedure Simulation_Finish
+   is
+      use Options;
+   begin
       if Nbr_Threads /= 1 then
          Threads.Finish;
       end if;
@@ -1042,6 +1112,17 @@ package body Grt.Processes is
       Call_Finalizers;
 
       Grt.Hooks.Call_Finish_Hooks;
+   end Simulation_Finish;
+
+   function Simulation return Integer
+   is
+      Status : Integer;
+   begin
+      Simulation_Init;
+
+      Status := Simulation_Main_Loop;
+
+      Simulation_Finish;
 
       return Status;
    end Simulation;
diff --git a/src/grt/grt-processes.ads b/src/grt/grt-processes.ads
index ecef800d4..00b057e41 100644
--- a/src/grt/grt-processes.ads
+++ b/src/grt/grt-processes.ads
@@ -48,9 +48,6 @@ package Grt.Processes is
    --  Number of non-delta cycles.
    Nbr_Cycles : Integer;
 
-   --  If true, the simulation should be stopped.
-   Break_Simulation : Boolean;
-
    type Process_Type is private;
    --  type Process_Acc is access all Process_Type;
 
diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb
index 444f1f033..48ab477c7 100644
--- a/src/grt/grt-rtis_addr.adb
+++ b/src/grt/grt-rtis_addr.adb
@@ -308,15 +308,13 @@ package body Grt.Rtis_Addr is
       end case;
    end Get_Base_Type;
 
-   function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean
-   is
+   function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean is
    begin
       return (Atype.Mode and Ghdl_Rti_Type_Complex_Mask)
         = Ghdl_Rti_Type_Complex;
    end Rti_Complex_Type;
 
-   function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean
-   is
+   function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean is
    begin
       return (Atype.Mode and Ghdl_Rti_Type_Anonymous_Mask)
         = Ghdl_Rti_Type_Anonymous;
diff --git a/src/grt/grt-signals.adb b/src/grt/grt-signals.adb
index fc97729c7..b86e23466 100644
--- a/src/grt/grt-signals.adb
+++ b/src/grt/grt-signals.adb
@@ -137,7 +137,7 @@ package body Grt.Signals is
 
    function Is_Signal_Guarded (Sig : Ghdl_Signal_Ptr) return Boolean is
    begin
-      return Sig.Sig_Kind /= Kind_Signal_No;
+      return Sig.Flags.Sig_Kind /= Kind_Signal_No;
    end Is_Signal_Guarded;
 
    function To_Address is new Ada.Unchecked_Conversion
@@ -211,13 +211,13 @@ package body Grt.Signals is
                               Event => False,
                               Active => False,
                               Has_Active => False,
-                              Sig_Kind => Sig_Kind,
 
-                              Is_Direct_Active => False,
                               Mode => Mode,
                               Flags => (Propag => Propag_None,
+                                        Sig_Kind => Sig_Kind,
+                                        Is_Direct_Active => False,
                                         Is_Dumped => False,
-                                        Cyc_Event => False,
+                                        RO_Event => False,
                                         Seen => False),
 
                               Net => No_Signal_Net,
@@ -536,7 +536,7 @@ package body Grt.Signals is
    function Has_Transaction_In_Next_Delta (Sig : Ghdl_Signal_Ptr)
                                           return Boolean  is
    begin
-      if Sig.Is_Direct_Active then
+      if Sig.Flags.Is_Direct_Active then
          return True;
       end if;
 
@@ -563,6 +563,14 @@ package body Grt.Signals is
    --  This signal is not in the signal table.
    Signal_End : Ghdl_Signal_Ptr;
 
+   --  List of signals that will be active in the next delta cycle.
+   Ghdl_Signal_Active_Chain : aliased Ghdl_Signal_Ptr;
+
+   --  List of implicit signals that will be active in the next cycle.
+   --  They are put in a different chain (other than ghdl_signal_active_chain),
+   --  because their handling is different.  FIXME: try to merge them ?
+   Ghdl_Implicit_Signal_Active_Chain : Ghdl_Signal_Ptr;
+
    --  List of signals which have projected waveforms in the future (beyond
    --  the next delta cycle).
    Future_List : aliased Ghdl_Signal_Ptr;
@@ -812,7 +820,7 @@ package body Grt.Signals is
       end if;
 
       --  Must be always set (as Sign.Link may be set by a regular driver).
-      Sign.Is_Direct_Active := True;
+      Sign.Flags.Is_Direct_Active := True;
    end Ghdl_Signal_Direct_Assign;
 
    procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr;
@@ -1750,31 +1758,102 @@ package body Grt.Signals is
       end if;
    end Ghdl_Signal_Driving_Value_F64;
 
-   Ghdl_Implicit_Signal_Active_Chain : Ghdl_Signal_Ptr;
+   type Force_Value_Kind is (Force_Driving, Force_Effective);
+   --  To add: Release_Driving, Release_Effective
+
+   type Force_Value (Kind : Force_Value_Kind);
+   type Force_Value_Acc is access Force_Value;
+
+   type Force_Value (Kind : Force_Value_Kind) is record
+      Next : Force_Value_Acc;
+      Sig : Ghdl_Signal_Ptr;
+      Val : Value_Union;
+   end record;
+
+   procedure Free is new Ada.Unchecked_Deallocation
+     (Force_Value, Force_Value_Acc);
+
+   --  Chain of forced values for the next cycle.
+   Force_Value_First : Force_Value_Acc;
+   Force_Value_Last : Force_Value_Acc;
+
+   procedure Append_Force_Value (F : Force_Value_Acc) is
+   begin
+      if Force_Value_First = null then
+         Force_Value_First := F;
+      else
+         Force_Value_Last.Next := F;
+      end if;
+      Force_Value_Last := F;
+   end Append_Force_Value;
+
+   procedure Ghdl_Signal_Force_Driving_B1 (Sig : Ghdl_Signal_Ptr;
+                                           Val : Ghdl_B1) is
+   begin
+      Append_Force_Value (new Force_Value'(Kind => Force_Driving,
+                                           Next => null,
+                                           Sig => Sig,
+                                           Val => (Mode => Mode_B1,
+                                                   B1 => Val)));
+   end Ghdl_Signal_Force_Driving_B1;
+
+   procedure Ghdl_Signal_Force_Effective_B1 (Sig : Ghdl_Signal_Ptr;
+                                             Val : Ghdl_B1) is
+   begin
+      Append_Force_Value (new Force_Value'(Kind => Force_Effective,
+                                           Next => null,
+                                           Sig => Sig,
+                                           Val => (Mode => Mode_B1,
+                                                   B1 => Val)));
+   end Ghdl_Signal_Force_Effective_B1;
+
+   procedure Ghdl_Signal_Force_Driving_E8 (Sig : Ghdl_Signal_Ptr;
+                                           Val : Ghdl_E8) is
+   begin
+      Append_Force_Value (new Force_Value'(Kind => Force_Driving,
+                                           Next => null,
+                                           Sig => Sig,
+                                           Val => (Mode => Mode_E8,
+                                                   E8 => Val)));
+   end Ghdl_Signal_Force_Driving_E8;
+
+   procedure Ghdl_Signal_Force_Effective_E8 (Sig : Ghdl_Signal_Ptr;
+                                             Val : Ghdl_E8) is
+   begin
+      Append_Force_Value (new Force_Value'(Kind => Force_Effective,
+                                           Next => null,
+                                           Sig => Sig,
+                                           Val => (Mode => Mode_E8,
+                                                   E8 => Val)));
+   end Ghdl_Signal_Force_Effective_E8;
+
+   --  Updated by Find_Next_Time to the list of signal that would be active
+   --  at the time returned (if not current_time).
+   Next_Signal_Active_Chain : Ghdl_Signal_Ptr;
 
-   procedure Flush_Active_List
+   --  Remove all (but Signal_End) signals in the active chain.
+   procedure Flush_Active_Chain
    is
       Sig : Ghdl_Signal_Ptr;
       Next_Sig : Ghdl_Signal_Ptr;
    begin
       --  Free active_chain.
-      Sig := Ghdl_Signal_Active_Chain;
+      Sig := Next_Signal_Active_Chain;
       loop
          Next_Sig := Sig.Link;
          exit when Next_Sig = null;
          Sig.Link := null;
          Sig := Next_Sig;
       end loop;
-      Ghdl_Signal_Active_Chain := Sig;
-   end Flush_Active_List;
+      Next_Signal_Active_Chain := Sig;
+   end Flush_Active_Chain;
 
-   function Find_Next_Time return Std_Time
+   function Find_Next_Time (Tn : Std_Time) return Std_Time
    is
       Res : Std_Time;
       Sig : Ghdl_Signal_Ptr;
 
-      procedure Check_Transaction (Trans : Transaction_Acc)
-      is
+      procedure Check_Transaction (Trans : Transaction_Acc) is
       begin
          if Trans = null or else Trans.Kind = Trans_Direct then
             --  Activity of direct drivers is done through link.
@@ -1782,14 +1861,15 @@ package body Grt.Signals is
          end if;
 
          if Trans.Time = Res and Sig.Link = null then
-            Sig.Link := Ghdl_Signal_Active_Chain;
-            Ghdl_Signal_Active_Chain := Sig;
+            --  Put to active list.
+            Sig.Link := Next_Signal_Active_Chain;
+            Next_Signal_Active_Chain := Sig;
          elsif Trans.Time < Res then
-            Flush_Active_List;
+            Flush_Active_Chain;
 
             --  Put sig on the list.
-            Sig.Link := Ghdl_Signal_Active_Chain;
-            Ghdl_Signal_Active_Chain := Sig;
+            Sig.Link := Next_Signal_Active_Chain;
+            Next_Signal_Active_Chain := Sig;
 
             Res := Trans.Time;
          end if;
@@ -1799,16 +1879,20 @@ package body Grt.Signals is
          end if;
       end Check_Transaction;
    begin
+      pragma Assert (Tn >= Current_Time);
       --  If there is signals in the active list, then next cycle is a delta
       --  cycle, so next time is current_time.
       if Ghdl_Signal_Active_Chain.Link /= null then
          return Current_Time;
       end if;
+      if Force_Value_First /= null then
+         return Current_Time;
+      end if;
       if Ghdl_Implicit_Signal_Active_Chain.Link /= null then
          return Current_Time;
       end if;
-      Res := Std_Time'Last;
 
+      Res := Tn;
       Sig := Future_List;
       while Sig.Flink /= null loop
          case Sig.S.Mode_Sig is
@@ -1828,6 +1912,13 @@ package body Grt.Signals is
       return Res;
    end Find_Next_Time;
 
+   procedure Update_Active_Chain is
+   begin
+      pragma Assert (Ghdl_Signal_Active_Chain.Link = null);
+      Ghdl_Signal_Active_Chain := Next_Signal_Active_Chain;
+      Next_Signal_Active_Chain := Signal_End;
+   end Update_Active_Chain;
+
 --    function Get_Nbr_Non_Null_Source (Sig : Ghdl_Signal_Ptr)
 --                                     return Natural
 --    is
@@ -1889,7 +1980,7 @@ package body Grt.Signals is
       --  if no driving sources and register, exit.
       if Length = 0
         and then Sig.Nbr_Ports = 0
-        and then Sig.Sig_Kind = Kind_Signal_Register
+        and then Sig.Flags.Sig_Kind = Kind_Signal_Register
       then
          return;
       end if;
@@ -2641,7 +2732,7 @@ package body Grt.Signals is
               (Resolv.Resolv_Proc
                  = To_Resolver_Acc (Ieee_Std_Logic_1164_Resolved_Resolv_Ptr))
               and then Sig.S.Nbr_Drivers + Sig.Nbr_Ports <= 1
-              and then Sig.Sig_Kind = Kind_Signal_No
+              and then Sig.Flags.Sig_Kind = Kind_Signal_No
             then
                --  Optimization: remove resolver if there is at most one
                --  source.
@@ -2831,7 +2922,7 @@ package body Grt.Signals is
          Sig.Value := Val;
          Sig.Event := True;
          Sig.Last_Event := Current_Time;
-         Sig.Flags.Cyc_Event := True;
+         Sig.Flags.RO_Event := True;
 
          El := Sig.Event_List;
          while El /= null loop
@@ -3106,6 +3197,35 @@ package body Grt.Signals is
       --  1) Reset active flag.
       Reset_Active_Flag;
 
+      --  Forced signals.
+      if Force_Value_First /= null then
+         declare
+            Fv : Force_Value_Acc;
+            Next_Fv : Force_Value_Acc;
+         begin
+            Fv := Force_Value_First;
+            while Fv /= null loop
+               Sig := Fv.Sig;
+               --  FIXME: Implement the full semantic of force: really force,
+               --  only set driving/effective value, release...
+               case Fv.Kind is
+                  when Force_Driving =>
+                     Mark_Active (Sig);
+                     Sig.Driving_Value := Fv.Val;
+                     Set_Effective_Value (Sig, Sig.Driving_Value);
+                  when Force_Effective =>
+                     Mark_Active (Sig);
+                     Set_Effective_Value (Sig, Fv.Val);
+               end case;
+               Next_Fv := Fv.Next;
+               Free (Fv);
+               Fv := Next_Fv;
+            end loop;
+            Force_Value_First := null;
+            Force_Value_Last := null;
+         end;
+      end if;
+
       --  For each active signals
       Sig := Ghdl_Signal_Active_Chain;
       Ghdl_Signal_Active_Chain := Signal_End;
@@ -3135,7 +3255,7 @@ package body Grt.Signals is
 
             when Net_One_Direct =>
                Mark_Active (Sig);
-               Sig.Is_Direct_Active := False;
+               Sig.Flags.Is_Direct_Active := False;
 
                Trans := Sig.S.Drivers (0).Last_Trans;
                Assign (Sig.Driving_Value, Trans.Val_Ptr.all, Sig.Mode);
@@ -3145,7 +3265,7 @@ package body Grt.Signals is
             when Net_One_Resolved =>
                --  This signal is active.
                Mark_Active (Sig);
-               Sig.Is_Direct_Active := False;
+               Sig.Flags.Is_Direct_Active := False;
 
                for J in 1 .. Sig.S.Nbr_Drivers loop
                   Trans := Sig.S.Drivers (J - 1).First_Trans.Next;
@@ -3166,7 +3286,7 @@ package body Grt.Signals is
                Internal_Error ("update_signals: no_signal_net");
 
             when others =>
-               Sig.Is_Direct_Active := False;
+               Sig.Flags.Is_Direct_Active := False;
                if not Propagation.Table (Sig.Net).Updated then
                   Propagation.Table (Sig.Net).Updated := True;
                   Run_Propagation (Sig.Net + 1);
@@ -3379,13 +3499,13 @@ package body Grt.Signals is
                                      Event => False,
                                      Active => False,
                                      Has_Active => False,
-                                     Is_Direct_Active => False,
-                                     Sig_Kind => Kind_Signal_No,
                                      Mode => Mode_B1,
 
                                      Flags => (Propag => Propag_None,
+                                               Sig_Kind => Kind_Signal_No,
+                                               Is_Direct_Active => False,
                                                Is_Dumped => False,
-                                               Cyc_Event => False,
+                                               RO_Event => False,
                                                Seen => False),
 
                                      Net => No_Signal_Net,
@@ -3404,6 +3524,7 @@ package body Grt.Signals is
       Ghdl_Signal_Active_Chain := Signal_End;
       Ghdl_Implicit_Signal_Active_Chain := Signal_End;
       Future_List := Signal_End;
+      Next_Signal_Active_Chain := Signal_End;
 
       Boolean_Signal_Rti.Obj_Type := Std_Standard_Boolean_RTI_Ptr;
       Bit_Signal_Rti.Obj_Type := Std_Standard_Bit_RTI_Ptr;
diff --git a/src/grt/grt-signals.ads b/src/grt/grt-signals.ads
index 8461e5e25..36ef69263 100644
--- a/src/grt/grt-signals.ads
+++ b/src/grt/grt-signals.ads
@@ -227,9 +227,6 @@ package Grt.Signals is
    Net_One_Direct : constant Signal_Net_Type := -2;
    Net_One_Resolved : constant Signal_Net_Type := -3;
 
-   --  Flush the list of active signals.
-   procedure Flush_Active_List;
-
    type Ghdl_Signal_Data (Mode_Sig : Mode_Signal_Type := Mode_Signal)
    is record
       case Mode_Sig is
@@ -273,12 +270,18 @@ package Grt.Signals is
       --  Status of the ordering.
       Propag : Propag_Order_Flag;
 
+      --  Kind of the signal (none, bus or register).
+      Sig_Kind : Kind_Signal_Type;
+
+      --  If set, the signal has an active direct driver.
+      Is_Direct_Active : Boolean;
+
       --  If set, the signal is dumped in a GHW file.
       Is_Dumped : Boolean;
 
       --  Set when an event occured.
       --  Only reset by GHW file dumper.
-      Cyc_Event : Boolean;
+      RO_Event : Boolean;
 
       --  Set if the signal has already been visited.  When outside of the
       --  algorithm that use it, it must be cleared.
@@ -302,12 +305,6 @@ package Grt.Signals is
       --  Internal fields.
       --  NOTE: keep above fields (components) in sync with translation.
 
-      --  If set, the signal has an active direct driver.
-      Is_Direct_Active : Boolean;
-
-      --  Kind of the signal (none, bus or register).
-      Sig_Kind : Kind_Signal_Type;
-
       --  Values mode of this signal.
       Mode : Mode_Type;
 
@@ -354,9 +351,6 @@ package Grt.Signals is
       Table_Low_Bound => 0,
       Table_Initial => 128);
 
-   --  Return the next time at which a driver becomes active.
-   function Find_Next_Time return Std_Time;
-
    --  Elementary propagation computation.
    --  See LRM 12.6.2 and 12.6.3
    type Propagation_Kind_Type is
@@ -481,7 +475,22 @@ package Grt.Signals is
    --  Initialize all signals.
    procedure Init_Signals;
 
-   --  Update signals.
+   --  Return the next time at which a driver becomes active.
+   --  SIDE EFFECT: this function updates the next_signal_active_chain.
+   --  Note: the next_signal_active_chain must be empty before running
+   --  processes as they assume that if signals are on a list, they are on the
+   --  ghdl_signal_active_chain (and not on next_signal_active_chain).  Use one
+   --  of Update_Active_Chain or Flush_Active_Chain for that effect.
+   function Find_Next_Time (Tn : Std_Time) return Std_Time;
+
+   --  To be called after Find_Next_Time to update the chain of active signals,
+   --  only if the next cycle is not a delta cycle.
+   procedure Update_Active_Chain;
+
+   --  Empty the next_signal_active_chain.
+   procedure Flush_Active_Chain;
+
+   --  Update all active signals.
    procedure Update_Signals;
 
    --  Set the effective value of signal SIG to VAL.
@@ -575,6 +584,10 @@ package Grt.Signals is
                                          After : Std_Time);
    function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr)
                                          return Ghdl_B1;
+   procedure Ghdl_Signal_Force_Driving_B1 (Sig : Ghdl_Signal_Ptr;
+                                           Val : Ghdl_B1);
+   procedure Ghdl_Signal_Force_Effective_B1 (Sig : Ghdl_Signal_Ptr;
+                                             Val : Ghdl_B1);
 
    function Ghdl_Create_Signal_E8 (Init_Val : Ghdl_E8;
                                    Resolv_Func : Resolver_Acc;
@@ -593,6 +606,10 @@ package Grt.Signals is
                                          After : Std_Time);
    function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr)
                                          return Ghdl_E8;
+   procedure Ghdl_Signal_Force_Driving_E8 (Sig : Ghdl_Signal_Ptr;
+                                           Val : Ghdl_E8);
+   procedure Ghdl_Signal_Force_Effective_E8 (Sig : Ghdl_Signal_Ptr;
+                                             Val : Ghdl_E8);
 
    function Ghdl_Create_Signal_E32 (Init_Val : Ghdl_E32;
                                     Resolv_Func : Resolver_Acc;
@@ -760,8 +777,6 @@ package Grt.Signals is
      (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type)
      return Ghdl_Value_Ptr;
 
-   Ghdl_Signal_Active_Chain : aliased Ghdl_Signal_Ptr;
-
    --  Statistics.
    Nbr_Active : Ghdl_I32;
    Nbr_Events: Ghdl_I32;
@@ -924,8 +939,4 @@ private
                   "__ghdl_signal_read_port");
    pragma Export (C, Ghdl_Signal_Read_Driver,
                   "__ghdl_signal_read_driver");
-
-   pragma Export (C, Ghdl_Signal_Active_Chain,
-                  "__ghdl_signal_active_chain");
-
 end Grt.Signals;
diff --git a/src/grt/grt-std_logic_1164.ads b/src/grt/grt-std_logic_1164.ads
index 4d1569553..b3b5d293c 100644
--- a/src/grt/grt-std_logic_1164.ads
+++ b/src/grt/grt-std_logic_1164.ads
@@ -26,7 +26,7 @@
 with Grt.Types; use Grt.Types;
 
 package Grt.Std_Logic_1164 is
-   type Std_Ulogic is ('U', 'X', '0', '1', 'Z', 'W','L', 'H', '-');
+   type Std_Ulogic is ('U', 'X', '0', '1', 'Z', 'W', 'L', 'H', '-');
 
    type Stdlogic_Table_2d is array (Std_Ulogic, Std_Ulogic) of Std_Ulogic;
    type Stdlogic_Table_1d is array (Std_Ulogic) of Std_Ulogic;
diff --git a/src/grt/grt-types.ads b/src/grt/grt-types.ads
index c0b3c3be0..71987119b 100644
--- a/src/grt/grt-types.ads
+++ b/src/grt/grt-types.ads
@@ -313,9 +313,6 @@ package Grt.Types is
 
    --  The NOW value.
    Current_Time : Std_Time;
-   --  Copy of Current_Time before updating it.
-   --  To be used by hooks.
-   Cycle_Time : Std_Time;
    --  The current delta cycle number.
    Current_Delta : Integer;
 private
diff --git a/src/grt/grt-vcd.adb b/src/grt/grt-vcd.adb
index 13da7f91a..d29ae2352 100644
--- a/src/grt/grt-vcd.adb
+++ b/src/grt/grt-vcd.adb
@@ -767,13 +767,42 @@ package body Grt.Vcd is
       return False;
    end Verilog_Wire_Changed;
 
+   function Verilog_Wire_Event (Info : Verilog_Wire_Info) return Boolean
+   is
+      Len : Ghdl_Index_Type;
+   begin
+      if Info.Irange = null then
+         Len := 1;
+      else
+         Len := Info.Irange.I32.Len;
+      end if;
+
+      case Info.Kind is
+         when Vcd_Bit
+           | Vcd_Bool
+           | Vcd_Stdlogic
+           | Vcd_Bitvector
+           | Vcd_Stdlogic_Vector
+           | Vcd_Integer32
+           | Vcd_Float64 =>
+            for J in 0 .. Len - 1 loop
+               if Info.Sigs (J).Event then
+                  return True;
+               end if;
+            end loop;
+         when Vcd_Bad =>
+            null;
+      end case;
+      return False;
+   end Verilog_Wire_Event;
+
    procedure Vcd_Put_Time
    is
       Str : String (1 .. 21);
       First : Natural;
    begin
       Vcd_Putc ('#');
-      Vstrings.To_String (Str, First, Ghdl_I64 (Cycle_Time));
+      Vstrings.To_String (Str, First, Ghdl_I64 (Current_Time));
       Vcd_Put (Str (First .. Str'Last));
       Vcd_Newline;
    end Vcd_Put_Time;
@@ -809,7 +838,7 @@ package body Grt.Vcd is
    begin
       --  Disp values.
       Vcd_Put_Time;
-      if Cycle_Time = 0 then
+      if Current_Time = 0 then
          --  Disp all values.
          for I in Vcd_Table.First .. Vcd_Table.Last loop
             Vcd_Put_Var (I);
@@ -817,7 +846,7 @@ package body Grt.Vcd is
       else
          --  Disp only values changed.
          for I in Vcd_Table.First .. Vcd_Table.Last loop
-            if Verilog_Wire_Changed (Vcd_Table.Table (I), Cycle_Time) then
+            if Verilog_Wire_Changed (Vcd_Table.Table (I), Current_Time) then
                Vcd_Put_Var (I);
             end if;
          end loop;
diff --git a/src/grt/grt-vcd.ads b/src/grt/grt-vcd.ads
index a3561f534..bc7917cba 100644
--- a/src/grt/grt-vcd.ads
+++ b/src/grt/grt-vcd.ads
@@ -63,9 +63,13 @@ package Grt.Vcd is
    function Get_Wire_Length (Info : Verilog_Wire_Info) return Ghdl_Index_Type;
 
    --  Return TRUE if last change time of the wire described by INFO is LAST.
+   --  Used by vcd to know if a signal has changed and should be dumped.
    function Verilog_Wire_Changed (Info : Verilog_Wire_Info;
                                   Last : Std_Time)
                                  return Boolean;
 
+   --  Return TRUE if there is an event on the wire, for the current cycle.
+   function Verilog_Wire_Event (Info : Verilog_Wire_Info) return Boolean;
+
    procedure Register;
 end Grt.Vcd;
diff --git a/src/grt/grt-vpi.adb b/src/grt/grt-vpi.adb
index bc594e44b..eedb8460c 100644
--- a/src/grt/grt-vpi.adb
+++ b/src/grt/grt-vpi.adb
@@ -44,13 +44,14 @@ pragma Unreferenced (System.Storage_Elements);
 with Grt.Stdio; use Grt.Stdio;
 with Grt.C; use Grt.C;
 with Grt.Signals; use Grt.Signals;
-with Grt.Table;
 with Grt.Astdio; use Grt.Astdio;
 with Grt.Hooks; use Grt.Hooks;
+with Grt.Options;
 with Grt.Vcd; use Grt.Vcd;
 with Grt.Errors; use Grt.Errors;
 with Grt.Rtis_Types;
-pragma Elaborate_All (Grt.Table);
+with Grt.Std_Logic_1164; use Grt.Std_Logic_1164;
+with Grt.Callbacks; use Grt.Callbacks;
 
 package body Grt.Vpi is
    --  The VPI interface requires libdl (dlopen, dlsym) to be linked in.
@@ -60,7 +61,11 @@ package body Grt.Vpi is
    --errAnyString:     constant String := "grt-vcd.adb: any string" & NUL;
    --errNoString:      constant String := "grt-vcd.adb: no string" & NUL;
 
-   type Vpi_Index_Type is new Integer;
+   Product : constant String := "GHDL" & NUL;
+   Version : constant String := "0.1" & NUL;
+
+   --  If true, emit traces
+   Flag_Trace : Boolean := False;
 
 -------------------------------------------------------------------------------
 -- * * *   h e l p e r s   * * * * * * * * * * * * * * * * * * * * * * * * * *
@@ -121,6 +126,26 @@ package body Grt.Vpi is
 --       return To_Ghdl_C_String (tmpstring1'Address);
 --    end NulTerminate1;
 
+   --  Clear error status.
+   procedure Reset_Error;
+
+   procedure Vpi_Trace (Msg : String) is
+   begin
+      if Flag_Trace then
+         Put_Line (Msg);
+      end if;
+   end Vpi_Trace;
+
+   function Vpi_Time_To_Time (V : s_vpi_time) return Std_Time is
+      Res : Std_Time;
+   begin
+      if V.mType /= vpiSimTime then
+         raise Program_Error;
+      end if;
+      Res := Std_Time (Unsigned_64 (V.mHigh) * 2 ** 32 + Unsigned_64 (V.mLow));
+      return Res * 1000;
+   end Vpi_Time_To_Time;
+
 -------------------------------------------------------------------------------
 -- * * *   V P I   f u n c t i o n s   * * * * * * * * * * * * * * * * * * * *
 -------------------------------------------------------------------------------
@@ -135,7 +160,9 @@ package body Grt.Vpi is
       Rel : VhpiOneToManyT;
       Error : AvhpiErrorT;
    begin
-      --dbgPut_Line ("vpi_iterate");
+      Vpi_Trace ("vpi_iterate");
+
+      Reset_Error;
 
       case aType is
          when vpiNet =>
@@ -190,9 +217,10 @@ package body Grt.Vpi is
 --       end case;
 --    end ii_vpi_get_type;
 
-   function vpi_get (Property: integer; Ref: vpiHandle) return Integer
-   is
+   function vpi_get (Property: integer; Ref: vpiHandle) return Integer is
    begin
+      Vpi_Trace ("vpi_get");
+
       case Property is
          when vpiType=>
             return Ref.mType;
@@ -204,6 +232,47 @@ package body Grt.Vpi is
       end case;
    end vpi_get;
 
+   function Vhpi_Handle_To_Vpi_Prop (Res : VhpiHandleT) return Integer is
+   begin
+      case Vhpi_Get_Kind (Res) is
+         when VhpiEntityDeclK
+           | VhpiArchBodyK
+           | VhpiBlockStmtK
+           | VhpiIfGenerateK
+           | VhpiForGenerateK
+           | VhpiCompInstStmtK =>
+            return vpiModule;
+         when VhpiPortDeclK
+           | VhpiSigDeclK =>
+            declare
+               Info : Verilog_Wire_Info;
+            begin
+               Get_Verilog_Wire (Res, Info);
+               if Info.Kind /= Vcd_Bad then
+                  return vpiNet;
+               end if;
+            end;
+         when others =>
+            null;
+      end case;
+      return vpiUndefined;
+   end Vhpi_Handle_To_Vpi_Prop;
+
+   function Build_vpiHandle (Res : VhpiHandleT; Prop : Integer)
+                            return vpiHandle is
+   begin
+      case Prop is
+         when vpiModule =>
+            return new struct_vpiHandle'(mType => vpiModule,
+                                         Ref => Res);
+         when vpiNet =>
+            return new struct_vpiHandle'(mType => vpiNet,
+                                         Ref => Res);
+         when others =>
+            return null;
+      end case;
+   end Build_vpiHandle;
+
    ------------------------------------------------------------------------
    -- vpiHandle  vpi_scan(vpiHandle iter)
    -- Scan the Verilog HDL hierarchy for objects with a one-to-many
@@ -214,8 +283,10 @@ package body Grt.Vpi is
       Res : VhpiHandleT;
       Error : AvhpiErrorT;
       R : vpiHandle;
+      Kind, Expected_Kind : Integer;
    begin
-      --dbgPut_Line ("vpi_scan");
+      Vpi_Trace ("vpi_scan");
+
       if Iter = null then
          return null;
       end if;
@@ -236,41 +307,24 @@ package body Grt.Vpi is
          end case;
       end if;
 
+      case Iter.mType is
+         when vpiInternalScope
+           | vpiModule =>
+            Expected_Kind := vpiModule;
+         when vpiNet =>
+            Expected_Kind := vpiNet;
+         when others =>
+            Expected_Kind := vpiUndefined;
+      end case;
+
       loop
          Vhpi_Scan (Iter.Ref, Res, Error);
          exit when Error /= AvhpiErrorOk;
 
-         case Vhpi_Get_Kind (Res) is
-            when VhpiEntityDeclK
-              | VhpiArchBodyK
-              | VhpiBlockStmtK
-              | VhpiIfGenerateK
-              | VhpiForGenerateK
-              | VhpiCompInstStmtK =>
-               case Iter.mType is
-                  when vpiInternalScope
-                    | vpiModule =>
-                     return new struct_vpiHandle'(mType => vpiModule,
-                                                  Ref => Res);
-                  when others =>
-                     null;
-               end case;
-            when VhpiPortDeclK
-              | VhpiSigDeclK =>
-               if Iter.mType = vpiNet then
-                  declare
-                     Info : Verilog_Wire_Info;
-                  begin
-                     Get_Verilog_Wire (Res, Info);
-                     if Info.Kind /= Vcd_Bad then
-                        return new struct_vpiHandle'(mType => vpiNet,
-                                                     Ref => Res);
-                     end if;
-                  end;
-               end if;
-            when others =>
-               null;
-         end case;
+         Kind := Vhpi_Handle_To_Vpi_Prop (Res);
+         if Kind /= vpiUndefined and then Kind = Expected_Kind then
+            return Build_vpiHandle (Res, Kind);
+         end if;
       end loop;
       return null;
    end vpi_scan;
@@ -285,7 +339,7 @@ package body Grt.Vpi is
       Prop : VhpiStrPropertyT;
       Len : Natural;
    begin
-      --dbgPut_Line ("vpiGetStr");
+      Vpi_Trace ("vpi_get_str");
 
       if Ref = null then
          return null;
@@ -323,7 +377,7 @@ package body Grt.Vpi is
    is
       Res : vpiHandle;
    begin
-      --dbgPut_Line ("vpi_handle");
+      Vpi_Trace ("vpi_handle");
 
       if Ref = null then
          return null;
@@ -457,9 +511,10 @@ package body Grt.Vpi is
       return To_Ghdl_C_String (Tmpstring3'Address);
    end ii_vpi_get_value_bin_str;
 
-   procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value)
-   is
+   procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value) is
    begin
+      Vpi_Trace ("vpi_get_value");
+
       case Value.Format is
          when vpiObjTypeVal=>
             -- fill in the object type and value:
@@ -517,89 +572,156 @@ package body Grt.Vpi is
    -- see IEEE 1364-2001, chapter 27.14, page 675
    -- FIXME
 
-   procedure ii_vpi_put_value_bin_str_B1 (SigPtr : Ghdl_Signal_Ptr;
-                                          Value : Character)
-   is
-      Tempval : Value_Union;
+   type Std_Ulogic_Array is array (Ghdl_Index_Type range <>) of Std_Ulogic;
+
+   procedure Ii_Vpi_Put_Value (Info : Verilog_Wire_Info;
+                               Vec : Std_Ulogic_Array) is
    begin
-      -- use the Set_Effective_Value procedure to update the signal
-      case Value is
-         when '0' =>
-            Tempval.B1 := false;
-         when '1' =>
-            Tempval.B1 := true;
-         when others =>
-            dbgPut_Line("ii_vpi_put_value_bin_str_B1: "
-                        & "wrong character - signal wont be set");
-            return;
-      end case;
-      SigPtr.Driving_Value := Tempval;
-      Set_Effective_Value (SigPtr, Tempval);
-   end ii_vpi_put_value_bin_str_B1;
-
-   procedure ii_vpi_put_value_bin_str_E8 (SigPtr : Ghdl_Signal_Ptr;
-                                          Value : Character)
-   is
-      Tempval : Value_Union;
-   begin
-      case Value is
-         when 'U' =>
-            Tempval.E8 := 0;
-         when 'X' =>
-            Tempval.E8 := 1;
-         when '0' =>
-            Tempval.E8 := 2;
-         when '1' =>
-            Tempval.E8 := 3;
-         when 'Z' =>
-            Tempval.E8 := 4;
-         when 'W' =>
-            Tempval.E8 := 5;
-         when 'L' =>
-            Tempval.E8 := 6;
-         when 'H' =>
-            Tempval.E8 := 7;
-         when '-' =>
-            Tempval.E8 := 8;
-         when others =>
-            dbgPut_Line("ii_vpi_put_value_bin_str_B8: "
-                        & "wrong character - signal wont be set");
+      case Info.Kind is
+         when Vcd_Bad =>
             return;
+         when Vcd_Bit
+           | Vcd_Bool
+           | Vcd_Bitvector =>
+            for J in Vec'Range loop
+               declare
+                  V : constant Ghdl_B1 :=
+                    Ghdl_B1 (Vec (J) = '1' or Vec (J) = 'H');
+               begin
+                  case Info.Val is
+                     when Vcd_Effective =>
+                        Ghdl_Signal_Force_Effective_B1 (Info.Sigs (J), V);
+                     when Vcd_Driving =>
+                        Ghdl_Signal_Force_Driving_B1 (Info.Sigs (J), V);
+                  end case;
+               end;
+            end loop;
+         when Vcd_Stdlogic
+           | Vcd_Stdlogic_Vector =>
+            for J in Vec'Range loop
+               declare
+                  V : constant Ghdl_E8 := Std_Ulogic'Pos (Vec (J));
+               begin
+                  case Info.Val is
+                     when Vcd_Effective =>
+                        Ghdl_Signal_Force_Effective_E8 (Info.Sigs (J), V);
+                     when Vcd_Driving =>
+                        Ghdl_Signal_Force_Driving_E8 (Info.Sigs (J), V);
+                  end case;
+               end;
+            end loop;
+         when Vcd_Integer32
+           | Vcd_Float64 =>
+            null;
       end case;
-      SigPtr.Driving_Value := Tempval;
-      Set_Effective_Value (SigPtr, Tempval);
-   end ii_vpi_put_value_bin_str_E8;
+   end Ii_Vpi_Put_Value;
 
+   procedure Ii_Vpi_Put_Value_Int (Info : Verilog_Wire_Info;
+                                   Len  : Ghdl_Index_Type;
+                                   Val : Unsigned_32)
+   is
+      V : Unsigned_32;
+      Vec : Std_Ulogic_Array (0 .. Len - 1);
+   begin
+      V := Val;
+      for J in reverse 0 .. Len - 1 loop
+         if (V mod 2) = 0 then
+            Vec (J) := '0';
+         else
+            Vec (J) := '1';
+         end if;
+         V := Shift_Right_Arithmetic (V, 1);
+      end loop;
+      Ii_Vpi_Put_Value (Info, Vec);
+   end Ii_Vpi_Put_Value_Int;
 
-   procedure ii_vpi_put_value_bin_str(Obj : VhpiHandleT;
-                                      ValueStr : Ghdl_C_String)
+   procedure Ii_Vpi_Put_Value_Bin_Str (Info : Verilog_Wire_Info;
+                                       Len : Ghdl_Index_Type;
+                                       Str : Ghdl_C_String)
    is
+      Slen : constant Natural := strlen (Str);
+      Soff : Integer;
+      Vec : Std_Ulogic_Array (0 .. Len - 1);
+      V : Std_Ulogic;
+   begin
+      Soff := Slen;
+      for J in reverse 0 .. Len - 1 loop
+         Soff := Soff - 1;
+         if Soff >= 0 then
+            case Str (Str'First + Soff) is
+               when 'u' | 'U' => V := 'U';
+               when 'x' | 'X' => V := 'X';
+               when '0'       => V := '0';
+               when '1'       => V := '1';
+               when 'z' | 'Z' => V := 'Z';
+               when 'w' | 'W' => V := 'W';
+               when 'l' | 'L' => V := 'L';
+               when 'h' | 'H' => V := 'H';
+               when '-'       => V := '-';
+               when others    => V := 'U';
+            end case;
+         else
+            V := '0';
+         end if;
+         Vec (J) := V;
+      end loop;
+      Ii_Vpi_Put_Value (Info, Vec);
+   end Ii_Vpi_Put_Value_Bin_Str;
+
+   -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value,
+   --                         p_vpi_time when, int flags)
+   function vpi_put_value (aObj : vpiHandle;
+                           aValue : p_vpi_value;
+                           aWhen : p_vpi_time;
+                           aFlags : integer)
+                         return vpiHandle
+   is
+      pragma Unreferenced (aWhen);
+      pragma Unreferenced (aFlags);
+
+      function To_Unsigned_32 is new Ada.Unchecked_Conversion
+        (Integer, Unsigned_32);
       Info : Verilog_Wire_Info;
       Len  : Ghdl_Index_Type;
    begin
+      Vpi_Trace ("vpi_put_value");
+      Reset_Error;
+
+      -- A very simple write procedure for VPI.
+      -- Basically, it accepts bin_str values and converts to appropriate
+      -- types (only std_logic and bit values and vectors).
+
+      -- It'll use Set_Effective_Value procedure to update signals
+
+      -- Ignoring aWhen and aFlags, for now.
+
       -- Check the Obj type.
       -- * The vpiHandle has a reference (field Ref) to a VhpiHandleT
       --   when it doesnt come from a callback.
-      case Vhpi_Get_Kind(Obj) is
+      case Vhpi_Get_Kind (aObj.Ref) is
          when VhpiPortDeclK
            | VhpiSigDeclK =>
             null;
          when others =>
-            return;
+            return null;
       end case;
 
       -- The following code segment was copied from the
       -- ii_vpi_get_value function.
       --  Get verilog compat info.
-      Get_Verilog_Wire (Obj, Info);
+      Get_Verilog_Wire (aObj.Ref, Info);
       if Info.Kind = Vcd_Bad then
-         return;
+         return null;
       end if;
 
       if Info.Irange = null then
          Len := 1;
       else
          Len := Info.Irange.I32.Len;
+         if Len = 0 then
+            --  No signal.
+            return null;
+         end if;
       end if;
 
       -- Step 1: convert vpi object to internal format.
@@ -613,63 +735,13 @@ package body Grt.Vpi is
       --         call (from grt-signals)
       -- Set_Effective_Value(sig_ptr, conv_value);
 
-
-      -- Took the skeleton from ii_vpi_get_value function
-      -- This point of the function must convert the string value to the
-      -- native ghdl format.
-      case Info.Kind is
-         when Vcd_Bad =>
-            return;
-         when Vcd_Bit
-           | Vcd_Bool
-           | Vcd_Bitvector =>
-            for J in 0 .. Len - 1 loop
-               ii_vpi_put_value_bin_str_B1
-                 (Info.Sigs (J), ValueStr (Integer (J + 1)));
-            end loop;
-         when Vcd_Stdlogic
-           | Vcd_Stdlogic_Vector =>
-            for J in 0 .. Len - 1 loop
-               ii_vpi_put_value_bin_str_E8
-                 (Info.Sigs (J), ValueStr (Integer (J + 1)));
-            end loop;
-         when Vcd_Integer32
-           | Vcd_Float64 =>
-            null;
-      end case;
-
-      -- Always return null, because this simulation kernel cannot send
-      -- a handle to the event back.
-      return;
-   end ii_vpi_put_value_bin_str;
-
-
-   -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value,
-   --                         p_vpi_time when, int flags)
-   function vpi_put_value (aObj: vpiHandle;
-                           aValue: p_vpi_value;
-                           aWhen: p_vpi_time;
-                           aFlags: integer)
-                         return vpiHandle
-   is
-      pragma Unreferenced (aWhen);
-      pragma Unreferenced (aFlags);
-   begin
-      -- A very simple write procedure for VPI.
-      -- Basically, it accepts bin_str values and converts to appropriate
-      -- types (only std_logic and bit values and vectors).
-
-      -- It'll use Set_Effective_Value procedure to update signals
-
-      -- Ignoring aWhen and aFlags, for now.
-
       -- Checks the format of aValue. Only vpiBinStrVal will be accepted
       --  for now.
       case aValue.Format is
          when vpiObjTypeVal =>
             dbgPut_Line ("vpi_put_value: vpiObjTypeVal");
          when vpiBinStrVal =>
-            ii_vpi_put_value_bin_str(aObj.Ref, aValue.Str);
+            Ii_Vpi_Put_Value_Bin_Str (Info, Len, aValue.Str);
             -- dbgPut_Line ("vpi_put_value: vpiBinStrVal");
          when vpiOctStrVal =>
             dbgPut_Line ("vpi_put_value: vpiNet, vpiOctStrVal");
@@ -680,7 +752,9 @@ package body Grt.Vpi is
          when vpiScalarVal =>
             dbgPut_Line ("vpi_put_value: vpiNet, vpiScalarVal");
          when vpiIntVal =>
-            dbgPut_Line ("vpi_put_value: vpiIntVal");
+            Ii_Vpi_Put_Value_Int
+              (Info, Len, To_Unsigned_32 (aValue.Integer_m));
+            -- dbgPut_Line ("vpi_put_value: vpiIntVal");
          when vpiRealVal =>
             dbgPut_Line("vpi_put_value: vpiRealVal");
          when vpiStringVal =>
@@ -703,71 +777,163 @@ package body Grt.Vpi is
    ------------------------------------------------------------------------
    -- void  vpi_get_time(vpiHandle obj, s_vpi_time*t);
    -- see IEEE 1364-2001, page xxx
-   Sim_Time : Std_Time;
    procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time)
    is
-      pragma Unreferenced (Obj);
+      function To_Unsigned_64 is new Ada.Unchecked_Conversion
+        (Std_Time, Unsigned_64);
+      V : Unsigned_64;
    begin
-      --dbgPut_Line ("vpi_get_time");
-      Time.mType := vpiSimTime;
-      Time.mHigh := 0;
-      Time.mLow  := Integer (Sim_Time / 1000000);
+      Vpi_Trace ("vpi_get_time");
+
+      if Obj /= null
+        or else Time.mType /= vpiSimTime
+      then
+         dbgPut_Line ("vpi_get_time: unhandled");
+         return;
+      end if;
+
+      V := To_Unsigned_64 (Current_Time) / 1000;
+      Time.mHigh := Unsigned_32 (V / 2 ** 32);
+      Time.mLow  := Unsigned_32 (V mod 2 ** 32);
       Time.mReal := 0.0;
    end vpi_get_time;
 
    ------------------------------------------------------------------------
-   -- vpiHandle vpi_register_cb(p_cb_data data)
-   g_cbEndOfCompile : p_cb_data;
-   g_cbEndOfSimulation: p_cb_data;
-   --g_cbValueChange:     s_cb_data;
-   g_cbReadOnlySync:    p_cb_data;
 
-   type Vpi_Var_Type is record
-      Info : Verilog_Wire_Info;
-      Cb   : s_cb_data;
+   type Callback_List is record
+      First, Last : vpiHandle;
    end record;
 
-   package Vpi_Table is new Grt.Table
-     (Table_Component_Type => Vpi_Var_Type,
-      Table_Index_Type     => Vpi_Index_Type,
-      Table_Low_Bound      => 0,
-      Table_Initial        => 32);
+   procedure Append_Callback (List : in out Callback_List; Hand : vpiHandle) is
+   begin
+      if List.First = null then
+         List.First := Hand;
+      else
+         List.Last.Cb_Next := Hand;
+         Hand.Cb_Prev := List.Last;
+      end if;
+      List.Last := Hand;
+      Hand.Cb_Next := null;
+   end Append_Callback;
+
+   procedure Execute_Callback (Hand : vpiHandle)
+   is
+      Res : Integer;
+      pragma Unreferenced (Res);
+   begin
+      Res := Hand.Cb.Cb_Rtn (Hand.Cb'Access);
+   end Execute_Callback;
+
+   procedure Execute_Callback_List (List : Callback_List)
+   is
+      H, Next_H : vpiHandle;
+   begin
+      H := List.First;
+      while H /= null loop
+         Next_H := H.Cb_Next;
+         --  The callback may destroy h.
+         Execute_Callback (H);
+         H := Next_H;
+      end loop;
+   end Execute_Callback_List;
+
+   -- vpiHandle vpi_register_cb(p_cb_data data)
+   g_cbEndOfCompile      : Callback_List;
+   g_cbStartOfSimulation : Callback_List;
+   g_cbEndOfSimulation   : Callback_List;
+
+   function To_Address is new Ada.Unchecked_Conversion
+     (vpiHandle, System.Address);
+
+   function To_vpiHandle is new Ada.Unchecked_Conversion
+     (System.Address, vpiHandle);
+
+   procedure Call_Callback (Arg : System.Address)
+   is
+      Hand : constant vpiHandle := To_vpiHandle (Arg);
+   begin
+      Vpi_Trace ("vpi: call callback");
+      Execute_Callback (Hand);
+   end Call_Callback;
+
+   procedure Call_Valuechange_Callback (Arg : System.Address)
+   is
+      Hand : constant vpiHandle := To_vpiHandle (Arg);
+   begin
+      if Verilog_Wire_Event (Hand.Cb_Wire) then
+         --  Note: the call may remove H from the list, or even
+         --  destroy it.
+         --  However, we assume it doesn't remove the next callback...
+         Vpi_Trace ("vpi: call valuechange cb");
+         Execute_Callback (Hand);
+      end if;
+   end Call_Valuechange_Callback;
+
+   procedure Resched_Callback (Arg : System.Address)
+   is
+      Hand : constant vpiHandle := To_vpiHandle (Arg);
+   begin
+      case Hand.Cb.Reason is
+         when cbReadOnlySynch =>
+            Register_Callback
+              (Cb_End_Of_Time_Step, Hand.Cb_Handle, Oneshot,
+               Call_Callback'Access, Arg);
+         when cbReadWriteSynch =>
+            Register_Callback
+              (Cb_Last_Known_Delta, Hand.Cb_Handle, Oneshot,
+               Call_Callback'Access, Arg);
+         when others =>
+            raise Program_Error;
+      end case;
+   end Resched_Callback;
 
    function vpi_register_cb (Data : p_cb_data) return vpiHandle
    is
-      Res : p_cb_data := null;
+      Res : vpiHandle;
+      T : Std_Time;
    begin
-      --dbgPut_Line ("vpi_register_cb");
+      Vpi_Trace ("vpi_register_cb");
+
+      Res := new struct_vpiHandle (vpiCallback);
+      Res.Cb := Data.all;
+
       case Data.Reason is
          when cbEndOfCompile =>
-            Res := new s_cb_data'(Data.all);
-            g_cbEndOfCompile := Res;
-            Sim_Time:= 0;
+            Append_Callback (g_cbEndOfCompile, Res);
+         when cbStartOfSimulation =>
+            Append_Callback (g_cbStartOfSimulation, Res);
          when cbEndOfSimulation =>
-            Res := new s_cb_data'(Data.all);
-            g_cbEndOfSimulation := Res;
+            Append_Callback (g_cbEndOfSimulation, Res);
          when cbValueChange =>
-            declare
-               N : Vpi_Index_Type;
-            begin
-               --g_cbValueChange:=     aData.all;
-               Vpi_Table.Increment_Last;
-               N := Vpi_Table.Last;
-               Vpi_Table.Table (N).Cb := Data.all;
-               Get_Verilog_Wire (Data.Obj.Ref, Vpi_Table.Table (N).Info);
-            end;
-         when cbReadOnlySynch=>
-            Res := new s_cb_data'(Data.all);
-            g_cbReadOnlySync := Res;
-         when others=>
-            dbgPut_Line ("vpi_register_cb: unknwon reason");
+            Get_Verilog_Wire (Data.Obj.Ref, Res.Cb_Wire);
+            Register_Callback
+              (Cb_Signals_Updated, Res.Cb_Handle, Repeat,
+               Call_Valuechange_Callback'Access, To_Address (Res));
+         when cbReadOnlySynch
+           | cbReadWriteSynch =>
+            T := Vpi_Time_To_Time (Data.Time.all);
+            if T = 0 then
+               Resched_Callback (To_Address (Res));
+            else
+               Register_Callback_At
+                 (Cb_After_Delay, Res.Cb_Handle, Current_Time + T,
+                  Resched_Callback'Access, To_Address (Res));
+            end if;
+         when cbAfterDelay =>
+            T := Vpi_Time_To_Time (Data.Time.all);
+            Register_Callback_At
+              (Cb_After_Delay, Res.Cb_Handle, Current_Time + T,
+               Call_Callback'Access, To_Address (Res));
+         when cbNextSimTime =>
+            Register_Callback
+              (Cb_Next_Time_Step, Res.Cb_Handle, Repeat,
+               Call_Callback'Access, To_Address (Res));
+         when others =>
+            dbgPut_Line ("vpi_register_cb: unknown reason");
+            Free (Res);
+            return null;
       end case;
-      if Res /= null then
-         return new struct_vpiHandle'(mType => vpiCallback,
-                                      Cb => Res);
-      else
-         return null;
-      end if;
+      return Res;
    end vpi_register_cb;
 
 -------------------------------------------------------------------------------
@@ -779,20 +945,24 @@ package body Grt.Vpi is
    is
       pragma Unreferenced (aRef);
    begin
-      return 0;
+      return 1;
    end vpi_free_object;
 
    -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p)
-   function vpi_get_vlog_info (aVlog_info_p: System.Address) return integer
-   is
-      pragma Unreferenced (aVlog_info_p);
+   function vpi_get_vlog_info (info : p_vpi_vlog_info) return integer is
    begin
+      Vpi_Trace ("vpi_get_vlog_info");
+
+      info.all := (Argc => 0,
+                   Argv => Null_Address,
+                   Product => To_Ghdl_C_String (Product'Address),
+                   Version => To_Ghdl_C_String (Version'Address));
       return 0;
    end vpi_get_vlog_info;
 
    -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index)
-   function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer)
-                               return vpiHandle
+   function vpi_handle_by_index (aRef: vpiHandle; aIndex: integer)
+                                return vpiHandle
    is
       pragma Unreferenced (aRef);
       pragma Unreferenced (aIndex);
@@ -800,6 +970,118 @@ package body Grt.Vpi is
       return null;
    end vpi_handle_by_index;
 
+   --  Return True iff L and R are equal.  L must not have an element set to
+   --  NUL.
+   function Strcmp (L : String; R : Ghdl_C_String) return Boolean is
+   begin
+      if L'Last < L'First - 1 then
+         --  Handle null string.
+         return R (1) = NUL;
+      end if;
+
+      for I in L'Range loop
+         if L (I) = NUL then
+            --  NUL not allowed in L.
+            return False;
+         end if;
+         if L (I) /= R (I - L'First + 1) then
+            return False;
+         end if;
+      end loop;
+
+      --  R is NUL terminated.
+      return R (L'Length + 1) = NUL;
+   end Strcmp;
+
+   procedure Find_By_Name (Scope : VhpiHandleT;
+                           Rel : VhpiOneToManyT;
+                           Name : String;
+                           Res : out VhpiHandleT;
+                           Err : out AvhpiErrorT)
+   is
+      It : VhpiHandleT;
+      El_Name : Ghdl_C_String;
+   begin
+      Vhpi_Iterator (Rel, Scope, It, Err);
+      if Err /= AvhpiErrorOk then
+         return;
+      end if;
+
+      loop
+         Vhpi_Scan (It, Res, Err);
+
+         --  Either a real error or end of iterator.
+         exit when Err /= AvhpiErrorOk;
+
+         El_Name := Avhpi_Get_Base_Name (Res);
+         exit when Strcmp (Name , El_Name);
+      end loop;
+   end Find_By_Name;
+
+   function vpi_handle_by_name (Name : Ghdl_C_String; Scope : vpiHandle)
+                               return vpiHandle
+   is
+      B, E : Natural;
+      Base, El : VhpiHandleT;
+      Err : AvhpiErrorT;
+      Prop : Integer;
+   begin
+      Vpi_Trace ("vpi_handle_by_name");
+
+      --  Extract the start point.
+      if Scope = null then
+         Get_Root_Scope (Base);
+      else
+         Base := Scope.Ref;
+      end if;
+
+      B := Name'First;
+
+      --  Iterate on each part of Name.
+      loop
+         exit when Name (B) = NUL;
+
+         --  Extract the next part of the name.
+         declare
+            C : Character;
+         begin
+            E := B;
+            loop
+               C := Name (E + 1);
+               exit when C = NUL or C = '.';
+               E := E + 1;
+            end loop;
+         end;
+
+         --  Find name in Base, first as a decl, then as a sub-region.
+         Find_By_Name (Base, VhpiDecls, Name (B .. E), El, Err);
+         if Err /= AvhpiErrorOk then
+            Find_By_Name (Base, VhpiInternalRegions, Name (B .. E), El, Err);
+         end if;
+
+         if Err = AvhpiErrorOk then
+            --  Found!
+            Base := El;
+         else
+            --  Not found.
+            return null;
+         end if;
+
+         --  Next path component.
+         B := E + 1;
+         exit when Name (B) = NUL;
+         pragma Assert (Name (B) = '.');
+         B := B + 1;
+      end loop;
+
+      Prop := Vhpi_Handle_To_Vpi_Prop (Base);
+      if Prop /= vpiUndefined then
+         return Build_vpiHandle (Base, Prop);
+      else
+         return null;
+      end if;
+   end vpi_handle_by_name;
+
    -- unsigned int vpi_mcd_close(unsigned int mcd)
    function vpi_mcd_close (Mcd: integer) return integer
    is
@@ -829,15 +1111,28 @@ package body Grt.Vpi is
    is
       pragma Unreferenced (aSs);
    begin
-      null;
+      Vpi_Trace ("vpi_register_systf");
    end vpi_register_systf;
 
    -- int vpi_remove_cb(vpiHandle ref)
    function vpi_remove_cb (Ref : vpiHandle) return Integer
    is
-      pragma Unreferenced (Ref);
+      Ref_Copy : vpiHandle;
    begin
-      return 0;
+      Vpi_Trace ("vpi_remove_cb");
+
+      case Ref.Cb.Reason is
+         when cbValueChange =>
+            Delete_Callback (Ref.Cb_Handle);
+         when cbReadWriteSynch
+           | cbReadOnlySynch =>
+            Delete_Callback (Ref.Cb_Handle);
+         when others =>
+            return 0;
+      end case;
+      Ref_Copy := Ref;
+      Free (Ref_Copy);
+      return 1;
    end vpi_remove_cb;
 
    -- void vpi_vprintf(const char*fmt, va_list ap)
@@ -856,7 +1151,54 @@ package body Grt.Vpi is
    --    vpi_mcd_fgetc
    --    vpi_sim_vcontrol
    --    vpi_chk_error
-   --    pi_handle_by_name
+   --    vpi_handle_by_name
+
+   Default_Message : constant String := "(no error message)" & NUL;
+   Unknown_File : constant String := "(no file)" & NUL;
+
+   Err_Message : Ghdl_C_String := To_Ghdl_C_String (Default_Message'Address);
+   Err_Code : Ghdl_C_String := null;
+   Err_File : Ghdl_C_String := To_Ghdl_C_String (Unknown_File'Address);
+   Err_Line : Integer := 0;
+   Err_Status : Integer := 0;
+
+   procedure Reset_Error is
+   begin
+      Err_Message := To_Ghdl_C_String (Default_Message'Address);
+      Err_Code := null;
+      Err_File := To_Ghdl_C_String (Unknown_File'Address);
+      Err_Line := 0;
+      Err_Status := 0;
+   end Reset_Error;
+
+   function vpi_chk_error (Info : p_vpi_error_info) return Integer is
+   begin
+      if Info /= null then
+         Info.all := (State => vpiRun,
+                      Level => vpiError,
+                      Message => Err_Message,
+                      Product => To_Ghdl_C_String (Product'Address),
+                      Code => Err_Code,
+                      File => Err_File,
+                      Line => Err_Line);
+      end if;
+      return Err_Status;
+   end vpi_chk_error;
+
+   function vpi_control (Op : Integer; Status : Integer) return Integer
+   is
+      pragma Unreferenced (Status);
+   begin
+      Vpi_Trace ("vpi_control");
+      case Op is
+         when vpiFinish
+           | vpiStop =>
+            Options.Break_Simulation := True;
+            return 1;
+         when others =>
+            return 0;
+      end case;
+   end vpi_control;
 
 ------------------------------------------------------------------------------
 -- * * *   G H D L   h o o k s   * * * * * * * * * * * * * * * * * * * * * * *
@@ -880,6 +1222,9 @@ package body Grt.Vpi is
          Vpi_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last);
          Vpi_Filename (Vpi_Filename'Last) := NUL;
          return True;
+      elsif Opt = "--vpi-trace" then
+         Flag_Trace := True;
+         return True;
       else
          return False;
       end if;
@@ -898,16 +1243,9 @@ package body Grt.Vpi is
    function LoadVpiModule (Filename: Address) return Integer;
    pragma Import (C, LoadVpiModule, "loadVpiModule");
 
-
    procedure Vpi_Init
    is
    begin
-      Sim_Time:= 0;
-
-      --g_cbEndOfCompile.mCb_rtn:= null;
-      --g_cbEndOfSimulation.mCb_rtn:= null;
-      --g_cbValueChange.mCb_rtn:= null;
-
       if Vpi_Filename /= null then
          if LoadVpiModule (Vpi_Filename.all'Address) /= 0 then
             Error ("cannot load VPI module");
@@ -915,8 +1253,6 @@ package body Grt.Vpi is
       end if;
    end Vpi_Init;
 
-   procedure Vpi_Cycle;
-
    ------------------------------------------------------------------------
    --  Called after elaboration.
    procedure Vpi_Start
@@ -929,47 +1265,18 @@ package body Grt.Vpi is
       end if;
 
       Grt.Rtis_Types.Search_Types_RTI;
-      Register_Cycle_Hook (Vpi_Cycle'Access);
-      if g_cbEndOfCompile /= null then
-         Res := g_cbEndOfCompile.Cb_Rtn.all (g_cbEndOfCompile);
-      end if;
+      Execute_Callback_List (g_cbEndOfCompile);
+      Execute_Callback_List (g_cbStartOfSimulation);
    end Vpi_Start;
 
    ------------------------------------------------------------------------
-   --  Called before each non delta cycle.
-   procedure Vpi_Cycle
-   is
-      Res : Integer;
-      pragma Unreferenced (Res);
-   begin
-      if g_cbReadOnlySync /= null
-        and then g_cbReadOnlySync.Time.mLow < Integer (Sim_Time / 1_000_000)
-      then
-         Res := g_cbReadOnlySync.Cb_Rtn.all (g_cbReadOnlySync);
-      end if;
-
-      for I in Vpi_Table.First .. Vpi_Table.Last loop
-         if Verilog_Wire_Changed (Vpi_Table.Table (I).Info, Sim_Time) then
-            Res := Vpi_Table.Table (I).Cb.Cb_Rtn.all
-              (To_p_cb_data (Vpi_Table.Table (I).Cb'Address));
-         end if;
-      end loop;
-
-      if Current_Time /= Std_Time'last then
-         Sim_Time:= Current_Time;
-      end if;
-   end Vpi_Cycle;
-
-   ------------------------------------------------------------------------
    --  Called at the end of the simulation.
    procedure Vpi_End
    is
       Res : Integer;
       pragma Unreferenced (Res);
    begin
-      if g_cbEndOfSimulation /= null then
-         Res := g_cbEndOfSimulation.Cb_Rtn.all (g_cbEndOfSimulation);
-      end if;
+      Execute_Callback_List (g_cbEndOfSimulation);
    end Vpi_End;
 
    Vpi_Hooks : aliased constant Hooks_Type :=
diff --git a/src/grt/grt-vpi.ads b/src/grt/grt-vpi.ads
index 86fb07374..ddfc7cf99 100644
--- a/src/grt/grt-vpi.ads
+++ b/src/grt/grt-vpi.ads
@@ -21,9 +21,12 @@
 --              Icarus Verilog Interactive (IVI) simulator GUI
 
 with System; use System;
+with Interfaces; use Interfaces;
 with Ada.Unchecked_Conversion;
 with Grt.Types; use Grt.Types;
 with Grt.Avhpi; use Grt.Avhpi;
+with Grt.Vcd;
+with Grt.Callbacks;
 
 package Grt.Vpi is
 
@@ -42,6 +45,10 @@ package Grt.Vpi is
    vpiLeftRange:     constant integer := 79;
    vpiRightRange:    constant integer := 83;
 
+   vpiStop   : constant := 66;
+   vpiFinish : constant := 67;
+   vpiReset  : constant := 68;
+
    --  Additionnal constants.
    vpiCallback :     constant Integer := 200;
 
@@ -64,12 +71,28 @@ package Grt.Vpi is
    vpiSimTime:       constant integer :=  2;
 
    -- codes for the reason tag of cb_data structure
-   cbValueChange:    constant integer:= 1;
-   cbReadOnlySynch:  constant integer:= 7;
-   cbEndOfCompile:   constant integer:= 10;
-   cbEndOfSimulation:constant integer:= 12;
-
-   type struct_vpiHandle (mType : Integer := vpiUndefined);
+   cbValueChange       : constant := 1;
+   cbReadWriteSynch    : constant := 6;
+   cbReadOnlySynch     : constant := 7;
+   cbNextSimTime       : constant := 8;
+   cbAfterDelay        : constant := 9;
+   cbEndOfCompile      : constant := 10;
+   cbStartOfSimulation : constant := 11;
+   cbEndOfSimulation   : constant := 12;
+
+   --  Error types.
+   vpiCompile : constant := 1;
+   vpiPLI     : constant := 2;
+   vpiRun     : constant := 3;
+
+   --  Error severity levels.
+   vpiNotive   : constant := 1;
+   vpiWarning  : constant := 2;
+   vpiError    : constant := 3;
+   vpiSystem   : constant := 4;
+   vpiInternal : constant := 5;
+
+   type struct_vpiHandle (<>) is private;
    type vpiHandle is access struct_vpiHandle;
 
    -- typedef struct t_vpi_time {
@@ -80,10 +103,11 @@ package Grt.Vpi is
    -- } s_vpi_time, *p_vpi_time;
    type s_vpi_time is record
       mType : Integer;
-      mHigh : Integer; -- this should be unsigned
-      mLow :  Integer; -- this should be unsigned
-      mReal : Float;   -- this should be double
+      mHigh : Unsigned_32;
+      mLow :  Unsigned_32;
+      mReal : Long_Float;
    end record;
+   pragma Convention (C, s_vpi_time);
    type p_vpi_time is access s_vpi_time;
 
    -- typedef struct t_vpi_value
@@ -118,7 +142,8 @@ package Grt.Vpi is
          when others =>
             null;
          end case;
-      end record;
+   end record;
+   --  No use of convention C, as there is no direct equivalent in the norm.
    type p_vpi_value is access s_vpi_value;
 
    --typedef struct t_cb_data {
@@ -128,11 +153,12 @@ package Grt.Vpi is
    --      p_vpi_time time;
    --      p_vpi_value value;
    --      int index;
-   --      char*user_data;
+   --      char *user_data;
    --} s_cb_data, *p_cb_data;
    type s_cb_data;
 
    type p_cb_data is access all s_cb_data;
+   pragma Convention (C, p_cb_data);
    function To_p_cb_data is new Ada.Unchecked_Conversion
      (Source => Address, Target => p_cb_data);
 
@@ -148,15 +174,7 @@ package Grt.Vpi is
       Index : Integer;
       User_Data : Address;
    end record;
-
-   type struct_vpiHandle (mType : Integer := vpiUndefined) is record
-      case mType is
-         when vpiCallback =>
-            Cb : p_cb_data;
-         when others =>
-            Ref   : VhpiHandleT;
-      end case;
-   end record;
+   pragma Convention (C, s_cb_data);
 
    -- vpiHandle  vpi_iterate(int type, vpiHandle ref)
    function vpi_iterate (aType : Integer; Ref : vpiHandle) return vpiHandle;
@@ -200,15 +218,31 @@ package Grt.Vpi is
    function vpi_free_object(aRef: vpiHandle) return integer;
    pragma Export (C, vpi_free_object, "vpi_free_object");
 
+   type s_vpi_vlog_info is record
+      Argc : Integer;
+      Argv : System.Address;
+      Product : Ghdl_C_String;
+      Version : Ghdl_C_String;
+   end record;
+   pragma Convention (C, s_vpi_vlog_info);
+
+   type p_vpi_vlog_info is access all s_vpi_vlog_info;
+   pragma Convention (C, p_vpi_vlog_info);
+
    -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p)
-   function vpi_get_vlog_info(aVlog_info_p: System.Address) return integer;
+   function vpi_get_vlog_info(info : p_vpi_vlog_info) return integer;
    pragma Export (C, vpi_get_vlog_info, "vpi_get_vlog_info");
 
+
    -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index)
    function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer)
                                return vpiHandle;
    pragma Export (C, vpi_handle_by_index, "vpi_handle_by_index");
 
+   function vpi_handle_by_name(Name : Ghdl_C_String; Scope : vpiHandle)
+                              return vpiHandle;
+   pragma Export (C, vpi_handle_by_name, "vpi_handle_by_name");
+
    -- unsigned int vpi_mcd_close(unsigned int mcd)
    function vpi_mcd_close (Mcd : Integer) return Integer;
    pragma Export (C, vpi_mcd_close, "vpi_mcd_close");
@@ -242,11 +276,49 @@ package Grt.Vpi is
    procedure vpi_vprintf (Fmt: Address; Ap: Address);
    pragma Export (C, vpi_vprintf, "vpi_vprintf");
 
+   --  typedef struct t_vpi_error_info
+   --  {
+   --      int32_t state;
+   --      int32_t level;
+   --      char *message;
+   --      char *product;
+   --      char *code;
+   --      char *file;
+   --      int32_t line;
+   --  } s_vpi_error_info, *p_vpi_error_info;
+   type s_vpi_error_info is record
+      State : Integer;
+      Level : Integer;
+      Message : Ghdl_C_String;
+      Product : Ghdl_C_String;
+      Code : Ghdl_C_String;
+      File : Ghdl_C_String;
+      Line : Integer;
+   end record;
+   type p_vpi_error_info is access all s_vpi_error_info;
+
+   function vpi_chk_error (Info : p_vpi_error_info) return Integer;
+   pragma Export (C, vpi_chk_error);
+
+   function vpi_control (Op : Integer; Status : Integer) return Integer;
+   pragma Export (C, vpi_control);
+
 -------------------------------------------------------------------------------
 -- * * *   G H D L   h o o k s   * * * * * * * * * * * * * * * * * * * * * * *
 -------------------------------------------------------------------------------
 
    procedure Register;
 
+private
+   type struct_vpiHandle (mType : Integer) is record
+      case mType is
+         when vpiCallback =>
+            Cb : aliased s_cb_data;
+            Cb_Prev, Cb_Next : vpiHandle;
+            Cb_Wire : Grt.Vcd.Verilog_Wire_Info;
+            Cb_Handle : Callbacks.Callback_Handle;
+         when others =>
+            Ref : VhpiHandleT;
+      end case;
+   end record;
 end Grt.Vpi;
-
diff --git a/src/grt/grt-waves.adb b/src/grt/grt-waves.adb
index 72b33d3e2..34124e2fc 100644
--- a/src/grt/grt-waves.adb
+++ b/src/grt/grt-waves.adb
@@ -1559,7 +1559,7 @@ package body Grt.Waves is
       Wave_Put_Byte (0);
       Wave_Put_Byte (0);
       Wave_Put_Byte (0);
-      Wave_Put_I64 (Ghdl_I64 (Cycle_Time));
+      Wave_Put_I64 (Ghdl_I64 (Current_Time));
 
       for I in Dump_Table.First .. Dump_Table.Last loop
          Write_Signal_Value (Dump_Table.Table (I));
@@ -1629,23 +1629,23 @@ package body Grt.Waves is
    begin
       if not In_Cyc then
          Wave_Section ("CYC" & NUL);
-         Wave_Put_I64 (Ghdl_I64 (Cycle_Time));
+         Wave_Put_I64 (Ghdl_I64 (Current_Time));
          In_Cyc := True;
       else
-         Diff := Cycle_Time - Wave_Time;
+         Diff := Current_Time - Wave_Time;
          Wave_Put_LSLEB128 (Ghdl_I64 (Diff));
       end if;
-      Wave_Time := Cycle_Time;
+      Wave_Time := Current_Time;
 
       --  Dump signals.
       Last := 0;
       for I in Dump_Table.First .. Dump_Table.Last loop
          Sig := Dump_Table.Table (I);
-         if Sig.Flags.Cyc_Event then
+         if Sig.Flags.RO_Event then
             Wave_Put_ULEB128 (Ghdl_U32 (I - Last));
             Last := I;
             Write_Signal_Value (Sig);
-            Sig.Flags.Cyc_Event := False;
+            Sig.Flags.RO_Event := False;
          end if;
       end loop;
       Wave_Put_Byte (0);