path: root/src/grt/grt-vhpi.adb

--  GHDL Run Time (GRT) - VHPI implementation.
--  Copyright (C) 2021 Marlon James
--
--  This program 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 of the License, or
--  (at your option) any later version.
--
--  This program 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 this program.  If not, see <gnu.org/licenses>.

with Ada.Unchecked_Conversion;
with Grt.Vhdl_Types; use Grt.Vhdl_Types;
with Grt.Astdio; use Grt.Astdio;
with Grt.Astdio.Vhdl; use Grt.Astdio.Vhdl;
with Grt.Errors; use Grt.Errors;
with Grt.Hooks; use Grt.Hooks;
with Grt.Stdio; use Grt.Stdio;
with Grt.Vstrings; use Grt.Vstrings;

package body Grt.Vhpi is
   --  The VHPI interface requires libdl (dlopen, dlsym) to be linked in.
   --  This is now set in Makefile, since this is target dependent.
   --  pragma Linker_Options ("-ldl");

   --  If true, emit traces
   Flag_Trace : Boolean := False;
   Trace_File : FILEs;

   VhpiUndefined_External : constant Integer := -1;


   ----------------------------------------------------------------------------
   -- Internal helper functions
   ----------------------------------------------------------------------------

   function To_Address is new Ada.Unchecked_Conversion
     (Vhpi_External_Handle, System.Address);

   -- VHPI errors

   Default_Message : constant String := "(no error message)" & NUL;

   Err_Severity : VhpiSeverityT := VhpiNote;
   Err_Message : Ghdl_C_String := To_Ghdl_C_String (Default_Message'Address);
   Err_Str : Ghdl_C_String := null;
   Err_File : Ghdl_C_String := null;
   Err_Line : Integer_32 := -1;
   Err_Occured : Boolean := False;

   Buf_Err_Message : Vstring;

   procedure Reset_Error is
   begin
      Err_Severity := VhpiNote;
      Err_Message := To_Ghdl_C_String (Default_Message'Address);
      Err_Str := null;
      Err_File := null;
      Err_Line := -1;
      Err_Occured := False;
   end Reset_Error;

   Err_Str_S : constant String := "GHDL Error ";
   -- VHPI function not implemented
   VHPI_0001_Str  : constant String := Err_Str_S & "VHPI_0001";

   procedure Set_Err_Str (S : String) is
   begin
      Err_Str := To_Ghdl_C_String (S'Address);
   end Set_Err_Str;

   procedure Error_Unimplimented (Name : String) is
   begin
      Err_Severity := VhpiError;
      Reset (Buf_Err_Message);
      Append (Buf_Err_Message, Name);
      Append (Buf_Err_Message, " not implemented");
      Append (Buf_Err_Message, NUL);
      Err_Message := Get_C_String (Buf_Err_Message);
      Set_Err_Str (VHPI_0001_Str);
      Err_Occured := True;
   end Error_Unimplimented;

   -- VHPI tracing

   procedure Trace_Start (Msg : String) is
   begin
      -- TODO: Add indent when callbacks are supported
      Put (Trace_File, Msg);
   end Trace_Start;

   procedure Trace_Newline is
   begin
      New_Line (Trace_File);
   end Trace_Newline;

   procedure Trace (Msg : String) is
   begin
      Put (Trace_File, Msg);
   end Trace;

   procedure Trace (Str : Ghdl_C_String) is
   begin
      if Str = null then
         Put (Trace_File, "null");
      else
         Put (Trace_File, '"');
         Put (Trace_File, Str);
         Put (Trace_File, '"');
      end if;
   end Trace;

   procedure Trace (V : Integer_32) is
   begin
      Put_I32 (Trace_File, Ghdl_I32 (V));
   end Trace;

   procedure Trace (V : Integer) is
   begin
      Put_I32 (Trace_File, Ghdl_I32 (V));
   end Trace;

   procedure Trace (V : Unsigned_64) is
   begin
      Put_U64 (Trace_File, Ghdl_U64 (V));
   end Trace;

   procedure Trace (A : System.Address)
   is
   begin
      Put (Trace_File, A);
   end Trace;

   procedure Trace (H : Vhpi_External_Handle)
   is
   begin
      Put (Trace_File, To_Address (H));
   end Trace;

   procedure Trace_Time (V : Std_Time) is
   begin
      Put_Time (Trace_File, V);
   end Trace_Time;

   function Vhpi_Time_To_Time (V : VhpiTimeT) return Std_Time is
      Res : Std_Time;
   begin
      Res := Std_Time (Integer_64 (V.High) * 2 ** 32 + Integer_64 (V.Low));
      return Res;
   end Vhpi_Time_To_Time;


   ----------------------------------------------------------------------------
   -- VHPI functions
   ----------------------------------------------------------------------------

   -- Internal implementations for variadic functions in grt-cvhpi.c

   function Vhpi_Assert_Internal (Severity: Integer; Msg : Ghdl_C_String)
                                 return Integer is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_assert (");
         Trace (Severity);
         Trace (", ");
         Trace (Msg);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_assert");

      if Flag_Trace then
         Trace ("1 [not implemented]");
         Trace_Newline;
      end if;
      return 1;
   end Vhpi_Assert_Internal;

   function Vhpi_Control_Internal (CommandInt : Integer; Status : Integer)
                                  return Integer
   is
      procedure Trace (C : VhpiSimControlT) is
      begin
         case C is
            when VhpiStop =>
               Trace ("vhpiStop");
            when VhpiFinish =>
               Trace ("vhpiFinish");
            when VhpiReset =>
               Trace ("vhpiReset");
         end case;
      end Trace;

      procedure Get_Command
        (C : Integer; Res : out VhpiSimControlT; Error : out AvhpiErrorT)
      is
         Ef : constant Integer := VhpiSimControlT'Pos (VhpiSimControlT'First);
         El : constant Integer := VhpiSimControlT'Pos (VhpiSimControlT'Last);
      begin
         Error := AvhpiErrorOk;
         if C not in Ef .. El then
            Error := AvhpiErrorBadEnumVal;
            Res := VhpiSimControlT'First;
            return;
         end if;
         Res := VhpiSimControlT'Val(C);
      end Get_Command;

      Command : VhpiSimControlT;
      Err : AvhpiErrorT;
   begin
      Get_Command (CommandInt, Command, Err);
      if Flag_Trace then
         Trace_Start ("vhpi_control (");
         if Err = AvhpiErrorOk then
            Trace (Command);
         else
            Trace (CommandInt);
            Trace (" {invalid command}");
         end if;
         Trace (", ");
         Trace (Status);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_control");

      if Flag_Trace then
         Trace ("1 [not implemented]");
         Trace_Newline;
      end if;
      return 1;
   end Vhpi_Control_Internal;

   ----------------------------------------------------------------------------
   -- Callback related

   -- vhpiHandleT vhpi_register_cb (vhpiCbDataT *cb_data_p, int32_t flags)
   function vhpi_register_cb (Data : VhpiCbData_Access; Flags : Callback_Flags)
                             return Vhpi_External_Handle is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_register_cb (");
         if Data = null then
            Trace (System.Null_Address);
         else
            Trace ("{reason=");
            -- TODO: Add callback reason string
            Trace (Data.Reason);
            if Data.Time /= null then
               Trace (", time=");
               Trace_Time (Vhpi_Time_To_Time (Data.Time.all));
            end if;
            Trace ("}");
         end if;
         Trace (", ");
         Trace (Integer_32 (Flags));
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_register_cb");

      if Flag_Trace then
         Trace (Null_External_Handle);
         Trace (" [not implemented]");
         Trace_Newline;
      end if;
      return Null_External_Handle;
   end vhpi_register_cb;

   -- int vhpi_remove_cb (vhpiHandleT cb_obj)
   function vhpi_remove_cb (Cb : Vhpi_External_Handle) return Integer is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_remove_cb (");
         Trace (Cb);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_remove_cb");

      if Flag_Trace then
         Trace ("1 [not implemented]");
         Trace_Newline;
      end if;
      return 1;
   end vhpi_remove_cb;

   -- int vhpi_disable_cb (vhpiHandleT cb_obj)
   function vhpi_disable_cb (Cb : Vhpi_External_Handle) return Integer is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_disable_cb (");
         Trace (Cb);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_disable_cb");

      if Flag_Trace then
         Trace ("1 [not implemented]");
         Trace_Newline;
      end if;
      return 1;
   end vhpi_disable_cb;

   -- int vhpi_enable_cb (vhpiHandleT cb_obj)
   function vhpi_enable_cb (Cb : Vhpi_External_Handle) return Integer is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_enable_cb (");
         Trace (Cb);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_enable_cb");

      if Flag_Trace then
         Trace ("1 [not implemented]");
         Trace_Newline;
      end if;
      return 1;
   end vhpi_enable_cb;

   -- int vhpi_get_cb_info (vhpiHandleT object, vhpiCbDataT *cb_data_p)
   function vhpi_get_cb_info
     (Obj : Vhpi_External_Handle; Data : VhpiCbData_Access) return Integer
   is
      function To_Address is
         new Ada.Unchecked_Conversion (VhpiCbData_Access, System.Address);
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_get_cb_info (");
         Trace (Obj);
         Trace (", ");
         Trace (To_Address (Data));
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_get_cb_info");

      if Flag_Trace then
         Trace ("1 [not implemented]");
         Trace_Newline;
      end if;
      return 1;
   end vhpi_get_cb_info;

   ----------------------------------------------------------------------------
   -- For obtaining handles

   -- vhpiHandleT vhpi_handle_by_name (const char *name, vhpiHandleT scope)
   function vhpi_handle_by_name
     (Name : Ghdl_C_String; Scope : Vhpi_External_Handle)
     return Vhpi_External_Handle is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_handle_by_name (");
         Trace (Name);
         Trace (", ");
         Trace (Scope);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_handle_by_name");

      if Flag_Trace then
         Trace (Null_External_Handle);
         Trace (" [not implemented]");
         Trace_Newline;
      end if;
      return Null_External_Handle;
   end vhpi_handle_by_name;

   -- vhpiHandleT vhpi_handle_by_index (vhpiOneToManyT itRel,
   --                                   vhpiHandleT parent, int32_t indx)
   function vhpi_handle_by_index
     (Rel : Integer; Parent : Vhpi_External_Handle; Index: Integer)
     return Vhpi_External_Handle is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_handle_by_index (");
         Trace (Integer_32 (Rel));
         Trace (", ");
         Trace (Parent);
         Trace (", ");
         Trace (Integer_32 (Index));
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_handle_by_index");

      if Flag_Trace then
         Trace (Null_External_Handle);
         Trace (" [not implemented]");
         Trace_Newline;
      end if;
      return Null_External_Handle;
   end vhpi_handle_by_index;

   ----------------------------------------------------------------------------
   -- For traversing relationships

   -- vhpiHandleT vhpi_handle (vhpiOneToOneT type, vhpiHandleT referenceHandle)
   function vhpi_handle (Rel: Integer; Ref: Vhpi_External_Handle)
                        return Vhpi_External_Handle is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_handle (");
         Trace (Integer_32 (Rel));
         Trace (", ");
         Trace (Ref);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_handle");

      if Flag_Trace then
         Trace (Null_External_Handle);
         Trace (" [not implemented]");
         Trace_Newline;
      end if;
      return Null_External_Handle;
   end vhpi_handle;

   -- vhpiHandleT vhpi_iterator (vhpiOneToManyT type,
   --                            vhpiHandleT referenceHandle)
   function vhpi_iterator (Rel: Integer; Ref: Vhpi_External_Handle)
                          return Vhpi_External_Handle is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_iterator (");
         Trace (Integer_32 (Rel));
         Trace (", ");
         Trace (Ref);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_iterator");

      if Flag_Trace then
         Trace (Null_External_Handle);
         Trace (" [not implemented]");
         Trace_Newline;
      end if;
      return Null_External_Handle;
   end vhpi_iterator;

   -- vhpiHandleT vhpi_scan (vhpiHandleT iterator)
   function vhpi_scan (Iter : Vhpi_External_Handle)
                      return Vhpi_External_Handle is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_scan (");
         Trace (Iter);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_scan");

      if Flag_Trace then
         Trace (Null_External_Handle);
         Trace (" [not implemented]");
         Trace_Newline;
      end if;
      return Null_External_Handle;
   end vhpi_scan;

   ----------------------------------------------------------------------------
   -- For processing properties

   -- vhpiIntT vhpi_get (vhpiIntPropertyT property, vhpiHandleT object)
   function vhpi_get (Property: Integer; Ref: Vhpi_External_Handle)
                     return VhpiIntT is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_get (");
         Trace (Integer_32 (Property));
         Trace (", ");
         Trace (Ref);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_get");

      if Flag_Trace then
         Trace (Integer_32 (VhpiUndefined_External));
         Trace (" [not implemented]");
         Trace_Newline;
      end if;
      return VhpiIntT (VhpiUndefined_External);
   end vhpi_get;

   -- const vhpiCharT * vhpi_get_str (vhpiStrPropertyT property,
   --                                 vhpiHandleT object)
   function vhpi_get_str (Property : Integer; Ref : Vhpi_External_Handle)
                         return Ghdl_C_String is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_get_str (");
         Trace (Integer_32 (Property));
         Trace (", ");
         Trace (Ref);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_get_str");

      if Flag_Trace then
         Trace (Ghdl_C_String'(null));
         Trace (" [not implemented]");
         Trace_Newline;
      end if;
      return null;
   end vhpi_get_str;

   -- vhpiRealT vhpi_get_real (vhpiRealPropertyT property, vhpiHandleT object)
   function vhpi_get_real (Property : Integer; Ref : Vhpi_External_Handle)
                          return Ghdl_Real is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_get_real (");
         Trace (Integer_32 (Property));
         Trace (", ");
         Trace (Ref);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_get_real");

      if Flag_Trace then
         Trace ("0.0 [not implemented]");
         Trace_Newline;
      end if;
      return 0.0;
   end vhpi_get_real;

   -- vhpiPhysT vhpi_get_phys (vhpiPhysPropertyT property, vhpiHandleT object)
   function vhpi_get_phys (Property : Integer; Ref : Vhpi_External_Handle)
                          return VhpiPhysT
   is
      procedure Trace (V : VhpiPhysT) is
      begin
         Put (Trace_File, "{high = ");
         Put_I32 (Trace_File, Ghdl_I32 (V.High));
         Put (Trace_File, ", low = ");
         Put_I32 (Trace_File, Ghdl_I32 (V.Low));
         Put (Trace_File, '}');
      end Trace;

      Res : constant VhpiPhysT := (0, 0);
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_get_phys (");
         Trace (Integer_32 (Property));
         Trace (", ");
         Trace (Ref);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_get_phys");

      if Flag_Trace then
         Trace (Res);
         Trace (" [not implemented]");
         Trace_Newline;
      end if;
      return Res;
   end vhpi_get_phys;

   ----------------------------------------------------------------------------
   -- For access to protected types

   -- int vhpi_protected_call (vhpiHandleT varHdl,
   --                          vhpiUserFctT userFct,
   --                          void *userData)
   function vhpi_protected_call (Var : Vhpi_External_Handle;
                                 User_Fun : VhpiUserFctT;
                                 User_Data : System.Address)
                                return Integer
   is
      function To_Address is new Ada.Unchecked_Conversion
        (VhpiUserFctT, System.Address);
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_protected_call (");
         Trace (Var);
         Trace (", ");
         Trace (To_Address (User_Fun));
         Trace (", ");
         Trace (User_Data);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_protected_call");

      if Flag_Trace then
         Trace ("-1 [not implemented]");
         Trace_Newline;
      end if;
      return -1;
   end vhpi_protected_call;

   ----------------------------------------------------------------------------
   -- For value processing

   function To_Address is new Ada.Unchecked_Conversion
     (VhpiValue_Access, System.Address);

   function To_Address is new Ada.Unchecked_Conversion
     (VhpiTime_Access, System.Address);

   -- int vhpi_get_value (vhpiHandleT expr, vhpiValueT *value_p)
   function vhpi_get_value
     (Expr : Vhpi_External_Handle; Value : VhpiValue_Access) return Integer is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_get_value (");
         Trace (Expr);
         Trace (", ");
         Trace (To_Address (Value));
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_get_value");

      if Flag_Trace then
         Trace ("-1 [not implemented]");
         Trace_Newline;
      end if;
      return -1;
   end vhpi_get_value;

   -- int vhpi_put_value (vhpiHandleT object,
   --                     vhpiValueT *value_p,
   --                     vhpiPutValueModeT mode)
   function vhpi_put_value (Obj : Vhpi_External_Handle;
                            Value : VhpiValue_Access;
                            ModeInt : Integer)
                           return Integer
   is
      procedure Trace (M : VhpiPutValueModeT) is
      begin
         case M is
            when VhpiDeposit =>
               Trace ("vhpiDeposit");
            when VhpiDepositPropagate =>
               Trace ("vhpiDepositPropagate");
            when VhpiForce =>
               Trace ("vhpiForce");
            when VhpiForcePropagate =>
               Trace ("vhpiForcePropagate");
            when VhpiRelease =>
               Trace ("vhpiRelease");
            when VhpiSizeConstraint =>
               Trace ("vhpiSizeConstraint");
         end case;
      end Trace;

      procedure Get_Mode
        (M : Integer; Res : out VhpiPutValueModeT; Error : out AvhpiErrorT)
      is
         Ef : constant Integer :=
           VhpiPutValueModeT'Pos (VhpiPutValueModeT'First);
         El : constant Integer :=
           VhpiPutValueModeT'Pos (VhpiPutValueModeT'Last);
      begin
         Error := AvhpiErrorOk;
         if M not in Ef .. El then
            Error := AvhpiErrorBadEnumVal;
            Res := VhpiPutValueModeT'First;
            return;
         end if;
         Res := VhpiPutValueModeT'Val(M);
      end Get_Mode;

      Mode : VhpiPutValueModeT;
      Err : AvhpiErrorT;
   begin
      Get_Mode (ModeInt, Mode, Err);
      if Flag_Trace then
         Trace_Start ("vhpi_put_value (");
         Trace (Obj);
         Trace (", ");
         -- TODO: Print value
         Trace (To_Address (Value));
         Trace (", ");
         if Err = AvhpiErrorOk then
            Trace (Mode);
         else
            Trace (ModeInt);
            Trace (" {invalid mode}");
         end if;
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_put_value");

      if Flag_Trace then
         Trace ("1 [not implemented]");
         Trace_Newline;
      end if;
      return 1;
   end vhpi_put_value;

   -- int vhpi_schedule_transaction (vhpiHandleT drivHdl,
   --                                vhpiValueT *value_p,
   --                                uint32_t numValues,
   --                                vhpiTimeT *delayp,
   --                                vhpiDelayModeT delayMode,
   --                                vhpiTimeT *pulseRejp)
   function vhpi_schedule_transaction (Driver : Vhpi_External_Handle;
                                       Value : VhpiValue_Access;
                                       Num_Values : Unsigned_32;
                                       Delay_Value : VhpiTime_Access;
                                       Delay_ModeInt : Integer;
                                       Pulse_Rejection : VhpiTime_Access)
                                      return Integer
   is
      procedure Trace (V : Unsigned_32) is
      begin
         Put_U32 (Trace_File, Ghdl_U32 (V));
      end Trace;

      procedure Trace (M : VhpiDelayModeT) is
      begin
         case M is
            when VhpiInertial =>
               Trace ("vhpiInertial");
            when VhpiTransport =>
               Trace ("vhpiTransport");
         end case;
      end Trace;

      procedure Get_Mode
        (M : Integer; Res : out VhpiDelayModeT; Error : out AvhpiErrorT)
      is
         Ef : constant Integer := VhpiDelayModeT'Pos (VhpiDelayModeT'First);
         El : constant Integer := VhpiDelayModeT'Pos (VhpiDelayModeT'Last);
      begin
         Error := AvhpiErrorOk;
         if M not in Ef .. El then
            Error := AvhpiErrorBadEnumVal;
            Res := VhpiDelayModeT'First;
            return;
         end if;
         Res := VhpiDelayModeT'Val(M);
      end Get_Mode;

      Delay_Mode : VhpiDelayModeT;
      Err : AvhpiErrorT;
   begin
      Get_Mode (Delay_ModeInt, Delay_Mode, Err);
      if Flag_Trace then
         Trace_Start ("vhpi_schedule_transaction (");
         Trace (Driver);
         Trace (", ");
         -- TODO: Print value
         Trace (To_Address (Value));
         Trace (", ");
         Trace (Num_Values);
         Trace (", ");
         if Delay_Value /= null then
            Trace ("{");
            Trace_Time (Vhpi_Time_To_Time (Delay_Value.all));
            Trace ("}");
         else
            Trace (To_Address (Delay_Value));
         end if;
         Trace (", ");
         if Err = AvhpiErrorOk then
            Trace (Delay_Mode);
         else
            Trace (Delay_ModeInt);
            Trace (" {invalid mode}");
         end if;
         Trace (", ");
         if Pulse_Rejection /= null then
            Trace ("{");
            Trace_Time (Vhpi_Time_To_Time (Pulse_Rejection.all));
            Trace ("}");
         else
            Trace (To_Address (Pulse_Rejection));
         end if;
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_schedule_transaction");

      if Flag_Trace then
         Trace ("1 [not implemented]");
         Trace_Newline;
      end if;
      return 1;
   end vhpi_schedule_transaction;

   -- int vhpi_format_value (const vhpiValueT *in_value_p,
   --                        vhpiValueT *out_value_p)
   function vhpi_format_value
     (In_Val : VhpiValue_Access; Out_Val : VhpiValue_Access) return Integer is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_format_value (");
         -- TODO: Print value
         Trace (To_Address (In_Val));
         Trace (", ");
         -- TODO: Print output format
         Trace (To_Address (Out_Val));
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_format_value");

      if Flag_Trace then
         Trace ("-1 [not implemented]");
         Trace_Newline;
      end if;
      return -1;
   end vhpi_format_value;

   ----------------------------------------------------------------------------
   -- For time processing

   -- void vhpi_get_time (vhpiTimeT *time_p, long *cycles)
   procedure vhpi_get_time (Time : VhpiTime_Access; Cycles : Long_Access)
   is
      function To_Address is new Ada.Unchecked_Conversion
        (Long_Access, System.Address);
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_get_time (");
         Trace (To_Address (Time));
         Trace (", ");
         Trace (To_Address (Cycles));
         Trace (") ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_get_time");

      if Flag_Trace then
         Trace ("[not implemented]");
         Trace_Newline;
      end if;
   end vhpi_get_time;

   -- int vhpi_get_next_time (vhpiTimeT *time_p)
   function vhpi_get_next_time (Time : VhpiTime_Access) return Integer is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_get_next_time (");
         Trace (To_Address (Time));
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_get_next_time");

      if Flag_Trace then
         Trace ("1 [not implemented]");
         Trace_Newline;
      end if;
      return 1;
   end vhpi_get_next_time;

   ----------------------------------------------------------------------------
   -- Utilities to print VHDL strings

   -- int vhpi_is_printable ( char ch )
   function vhpi_is_printable (Ch : Character) return Integer
   is
      procedure Trace (C : Character) is
      begin
         Put (Trace_File, C);
      end Trace;
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_is_printable (");
         Trace (Ch);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_is_printable");

      if Flag_Trace then
         Trace ("0 [not implemented]");
         Trace_Newline;
      end if;
      return 0;
   end vhpi_is_printable;

   ----------------------------------------------------------------------------
   -- Utility routines

   -- int vhpi_compare_handles (vhpiHandleT handle1, vhpiHandleT handle2)
   function vhpi_compare_handles (Hdl1, Hdl2 : Vhpi_External_Handle)
                                 return Integer is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_compare_handles (");
         Trace (Hdl1);
         Trace (", ");
         Trace (Hdl2);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_compare_handles");

      if Flag_Trace then
         Trace ("0 [not implemented]");
         Trace_Newline;
      end if;
      return 0;
   end vhpi_compare_handles;

   -- int vhpi_check_error (vhpiErrorInfoT *error_info_p)
   function vhpi_check_error (Info : VhpiErrorInfo_Access) return Integer
   is
      function To_Address is new Ada.Unchecked_Conversion
        (VhpiErrorInfo_Access, System.Address);

      function To_Integer (B : Boolean) return Integer is
      begin
         if B then
            return 1;
         else
            return 0;
         end if;
      end To_Integer;

      Res : Integer;
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_check_error (");
         Trace (To_Address (Info));
         Trace (") return ");
      end if;

      if Info /= null then
         Info.all := (Severity => Err_Severity,
                      Msg => Err_Message,
                      Str => Err_Str,
                      File => Err_File,
                      Line => Err_Line);
      end if;

      Res := To_Integer (Err_Occured);

      if Flag_Trace then
         Trace (Res);
         Trace_Newline;
      end if;
      return Res;
   end vhpi_check_error;

   -- int vhpi_release_handle (vhpiHandleT object)
   function vhpi_release_handle (Obj : Vhpi_External_Handle) return Integer is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_release_handle (");
         Trace (To_Address (Obj));
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_release_handle");

      if Flag_Trace then
         Trace ("1 [not implemented]");
         Trace_Newline;
      end if;
      return 1;
   end vhpi_release_handle;

   ----------------------------------------------------------------------------
   -- Creation functions
   -- vhpiHandleT vhpi_create (vhpiClassKindT kind,
   --                          vhpiHandleT handle1,
   --                          vhpiHandleT handle2)
   function vhpi_create (Kind : Integer; Hdl1, Hdl2 : Vhpi_External_Handle)
                        return Vhpi_External_Handle is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_create (");
         Trace (Kind);
         Trace (", ");
         Trace (Hdl1);
         Trace (", ");
         Trace (Hdl2);
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_create");

      if Flag_Trace then
         Trace (Null_External_Handle);
         Trace (" [not implemented]");
         Trace_Newline;
      end if;
      return Null_External_Handle;
   end vhpi_create;

   ----------------------------------------------------------------------------
   -- Foreign model data structures and functions

   function To_Address is new Ada.Unchecked_Conversion
     (VhpiForeignData_Access, System.Address);

   -- vhpiHandleT vhpi_register_foreignf (vhpiForeignDataT *foreignDatap)
   function vhpi_register_foreignf (Data : VhpiForeignData_Access)
                                   return Vhpi_External_Handle is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_register_foreignf (");
         -- TODO: Print foreign model info
         Trace (To_Address (Data));
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_register_foreignf");

      if Flag_Trace then
         Trace (Null_External_Handle);
         Trace (" [not implemented]");
         Trace_Newline;
      end if;
      return Null_External_Handle;
   end vhpi_register_foreignf;

   -- int vhpi_get_foreignf_info (vhpiHandleT hdl,
   --                             vhpiForeignDataT *foreignDatap)
   function vhpi_get_foreignf_info
     (Hdl : Vhpi_External_Handle; Data : VhpiForeignData_Access)
     return Integer is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_get_foreignf_info (");
         Trace (Hdl);
         Trace (", ");
         Trace (To_Address (Data));
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_get_foreignf_info");

      if Flag_Trace then
         Trace ("1 [not implemented]");
         Trace_Newline;
      end if;
      return 1;
   end vhpi_get_foreignf_info;

   ----------------------------------------------------------------------------
   -- For saving and restoring foreign models data

   -- size_t vhpi_get_data (int32_t id, void *dataLoc, size_t numBytes);
   function vhpi_get_data
     (Id : Integer_32; Data_Loc : System.Address; Num_Bytes : size_t)
     return size_t is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_get_data (");
         Trace (Id);
         Trace (", ");
         Trace (Data_Loc);
         Trace (", ");
         Trace (Unsigned_64 (Num_Bytes));
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_get_data");

      if Flag_Trace then
         Trace ("0 [not implemented]");
         Trace_Newline;
      end if;
      return 0;
   end vhpi_get_data;

   -- size_t vhpi_put_data (int32_t id, void *dataLoc, size_t numBytes);
   function vhpi_put_data
     (Id : Integer_32; Data_Loc : System.Address; Num_Bytes : size_t)
     return size_t is
   begin
      if Flag_Trace then
         Trace_Start ("vhpi_put_data (");
         Trace (Id);
         Trace (", ");
         Trace (Data_Loc);
         Trace (", ");
         Trace (Unsigned_64 (Num_Bytes));
         Trace (") return ");
      end if;
      Reset_Error;

      Error_Unimplimented ("vhpi_put_data");

      if Flag_Trace then
         Trace ("0 [not implemented]");
         Trace_Newline;
      end if;
      return 0;
   end vhpi_put_data;


   ----------------------------------------------------------------------------
   -- GHDL hooks
   ----------------------------------------------------------------------------

   type Lib_Cell;
   type Lib_Access is access Lib_Cell;

   type Lib_Cell is record
      File_Name : String_Access;
      Func_Name : String_Access;
      Next : Lib_Access;
   end record;

   Vhpi_Libraries : Lib_Access := null;

   procedure Vhpi_Help is
   begin
      Put_Line
        (" --vhpi=FILENAME[:ENTRYPOINT]  load VHPI library, optionally");
      Put_Line
        ("                               provide entry point name");
      Put_Line
        (" --vhpi-trace[=FILE]  trace vhpi calls to stdout or provided FILE");
   end Vhpi_Help;

   ------------------------------------------------------------------------
   --  Return TRUE if OPT is an option for VHPI.
   function Vhpi_Option (Opt : String) return Boolean
   is
      F : constant Natural := Opt'First;

      procedure Bad_Option is
      begin
         Error_S ("incorrect option '");
         Diag_C (Opt);
         Error_E ("'");
      end Bad_Option;
   begin
      if Opt'Length < 6 or else Opt (F .. F + 5) /= "--vhpi" then
         return False;
      end if;
      if Opt'Length = 7 then
         Bad_Option;
         return False;
      end if;
      if Opt'Length > 7 and then Opt (F + 6) = '=' then
         -- Need to support Windows path names and optional entrypoint.
         -- Valid examples:
         -- C:\vhpi_lib.dll:entry_func
         -- .\vhpi_lib.dll:entry_func
         -- ./vhpi_lib.so:entry_func
         -- /path/to/vhpi_lib:entry_func
         -- vhpi_lib:entry_func
         declare
            P : Natural;
            Lf, Ll, L_Len : Natural;
            Ef, El, E_Len : Natural;
            Lib : Lib_Access;
            File : String_Access;
            Func : String_Access;
         begin
            P := F + 7;
            -- Extract library.
            Lf := P;
            while P <= Opt'Length and then Opt (P) /= ':' loop
               P := P + 1;
            end loop;
            -- Skip colon after volume/drive letter on Windows.
            -- This will break if library path is one character.
            if P <= Opt'Length and then Opt (P) = ':' and then P = 2 then
               while P <= Opt'Length and then Opt (P) /= ':' loop
                  P := P + 1;
               end loop;
            end if;
            Ll := P - 1;

            -- Extract entrypoint.
            Ef := P + 1;
            El := Opt'Length;

            -- Store library info.
            Lib := new Lib_Cell;
            --  Add an extra NUL character.
            L_Len := Ll - Lf + 2;
            File := new String (1 .. L_Len);
            File (1 .. L_Len - 1) := Opt (Lf .. Ll);
            File (File'Last) := NUL;
            Lib.File_Name := File;
            if Ef <= El then
               --  Add an extra NUL character.
               E_Len := El - Ef + 2;
               Func := new String (1 .. E_Len);
               Func (1 .. E_Len - 1) := Opt (Ef .. El);
               Func (Func'Last) := NUL;
               Lib.Func_Name := Func;
            end if;

            -- Add new library to the list.
            if Vhpi_Libraries = null then
               Vhpi_Libraries := Lib;
            else
               declare
                  L : Lib_Access := Vhpi_Libraries;
               begin
                  while L.Next /= null loop
                     L := L.Next;
                  end loop;
                  L.Next := Lib;
               end;
            end if;
         end;
         return True;
      elsif Opt'Length >= 12 and then Opt (F + 6 .. F + 11) = "-trace" then
         if Opt'Length > 12 and then Opt (F + 12) = '=' then
            declare
               Filename : String (1 .. Opt'Length - 12);
               Mode : constant String := "wt" & NUL;
            begin
               Filename (1 .. Filename'Last - 1) := Opt (F + 13 .. Opt'Last);
               Filename (Filename'Last) := NUL;
               Trace_File := fopen (Filename'Address, Mode'Address);
               if Trace_File = NULL_Stream then
                  Error_S ("cannot open vhpi trace file '");
                  Diag_C (Opt (F + 13 .. Opt'Last));
                  Error_E ("'");
                  return False;
               end if;
            end;
         elsif Opt'Length = 12 then
            Trace_File := stdout;
         else
            Bad_Option;
            return False;
         end if;
         Flag_Trace := True;
         return True;
      else
         return False;
      end if;
   end Vhpi_Option;

   ------------------------------------------------------------------------
   --  Called before elaboration.

   -- int loadVhpiModule (const char* libname, const char* entrypoint)
   function LoadVhpiModule (Filename, Funcname: Address) return Integer;
   pragma Import (C, LoadVhpiModule, "loadVhpiModule");

   procedure Vhpi_Init
   is
      Lib : Lib_Access := Vhpi_Libraries;
      Res : Integer;
   begin
      if Lib = null then
         return;
      end if;
      while Lib /= null loop
         if Lib.Func_Name = null then
            Res := LoadVhpiModule
              (Lib.File_Name.all'Address, Null_Address);
         else
            Res := LoadVhpiModule
              (Lib.File_Name.all'Address, Lib.Func_Name.all'Address);
         end if;

         if Res /= 0 then
            Error_S ("cannot load VHPI module '");
            Diag_C (Lib.File_Name.all);
            if Lib.Func_Name /= null then
               Diag_C ("' with entry point '");
               Diag_C (Lib.Func_Name.all);
            end if;
            Error_E ("'");
         end if;
         Lib := Lib.Next;
      end loop;
   end Vhpi_Init;

   ------------------------------------------------------------------------
   --  Called after elaboration.
   procedure Vhpi_Start is
   begin
      if Vhpi_Libraries = null then
         return;
      end if;

      -- Grt.Rtis_Types.Search_Types_RTI;
      -- Execute_Callback_List (VhpiCbStartOfSimulation_List);
   end Vhpi_Start;

   ------------------------------------------------------------------------
   --  Called at the end of the simulation.
   procedure Vhpi_End is
   begin
      -- Execute_Callback_List (VhpiCbEndOfSimulation_List);
      Free (Buf_Err_Message);
      null;
   end Vhpi_End;

   Vhpi_Hooks : aliased constant Hooks_Type :=
     (Desc => new String'("vhpi: vhpi compatible API"),
      Option => Vhpi_Option'Access,
      Help => Vhpi_Help'Access,
      Init => Vhpi_Init'Access,
      Start => Vhpi_Start'Access,
      Finish => Vhpi_End'Access);

   procedure Register is
   begin
      Register_Hooks (Vhpi_Hooks'Access);
   end Register;

end Grt.Vhpi;