grt-vcd.adb

vhdl集成电路设计软件.需要用gcc-4.0.2版本编译.

--  GHDL Run Time (GRT) - VCD generator.
--  Copyright (C) 2002, 2003, 2004, 2005 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.
with Interfaces;
with Grt.Stdio; use Grt.Stdio;
with System; use System;
with System.Storage_Elements; --  Work around GNAT bug.
with Grt.Errors; use Grt.Errors;
with Grt.Types; use Grt.Types;
with Grt.Signals; use Grt.Signals;
with GNAT.Table;
with Grt.Astdio; use Grt.Astdio;
with Grt.C; use Grt.C;
with Grt.Hooks; use Grt.Hooks;
with Grt.Avhpi; use Grt.Avhpi;
with Grt.Rtis; use Grt.Rtis;
with Grt.Rtis_Addr; use Grt.Rtis_Addr;
with Grt.Rtis_Types; use Grt.Rtis_Types;
with Grt.Vstrings;

package body Grt.Vcd is
   --  If TRUE, put $date in vcd file.
   --  Can be set to FALSE to make vcd comparaison easier.
   Flag_Vcd_Date : Boolean := True;

   type Vcd_IO_Simple is new Vcd_IO_Handler with record
      Stream : FILEs;
   end record;
   type IO_Simple_Acc is access Vcd_IO_Simple;
   procedure Vcd_Put (Handler : access Vcd_IO_Simple; Str : String);
   procedure Vcd_Putc (Handler : access Vcd_IO_Simple; C : Character);
   procedure Vcd_Close (Handler : access Vcd_IO_Simple);

   procedure Vcd_Put (Handler : access Vcd_IO_Simple; Str : String)
   is
      R : size_t;
   begin
      R := fwrite (Str'Address, Str'Length, 1, Handler.Stream);
   end Vcd_Put;

   procedure Vcd_Putc (Handler : access Vcd_IO_Simple; C : Character)
   is
      R : int;
   begin
      R := fputc (Character'Pos (C), Handler.Stream);
   end Vcd_Putc;

   procedure Vcd_Close (Handler : access Vcd_IO_Simple) is
   begin
      fclose (Handler.Stream);
      Handler.Stream := NULL_Stream;
   end Vcd_Close;

   --  VCD filename.
   --  Stream corresponding to the VCD filename.
   --Vcd_Stream : FILEs;

   --  Index type of the table of vcd variables to dump.
   type Vcd_Index_Type is new Integer;

   --  Return TRUE if OPT is an option for VCD.
   function Vcd_Option (Opt : String) return Boolean
   is
      F : Natural := Opt'First;
      Mode : constant String := "wt" & NUL;
      Handler : IO_Simple_Acc;
      Vcd_Filename : String_Access;
   begin
      if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vcd" then
         return False;
      end if;
      if Opt'Length = 12 and then Opt (F + 5 .. F + 11) = "-nodate" then
         Flag_Vcd_Date := False;
         return True;
      end if;
      if Opt'Length > 6 and then Opt (F + 5) = '=' then
         if H /= null then
            Error ("--vcd: file already set");
            return True;
         end if;

         --  Add an extra NUL character.
         Vcd_Filename := new String (1 .. Opt'Length - 6 + 1);
         Vcd_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last);
         Vcd_Filename (Vcd_Filename'Last) := NUL;

         Handler := new Vcd_IO_Simple;
         if Vcd_Filename.all = "-" & NUL then
            Handler.Stream := stdout;
         else
            Handler.Stream := fopen (Vcd_Filename.all'Address, Mode'Address);
            if Handler.Stream = NULL_Stream then
               Error_C ("cannot open ");
               Error_E (Vcd_Filename (Vcd_Filename'First
                                      .. Vcd_Filename'Last - 1));
               return True;
            end if;
         end if;
         H := Handler_Acc (Handler);
         return True;
      else
         return False;
      end if;
   end Vcd_Option;

   procedure Vcd_Help is
   begin
      Put_Line (" --vcd=FILENAME     dump signal values into a VCD file");
      Put_Line (" --vcd-nodate       do not write date in VCD file");
   end Vcd_Help;

   procedure Vcd_Put (Str : String) is
   begin
      Vcd_Put (H, Str);
   end Vcd_Put;

   procedure Vcd_Putc (C : Character) is
   begin
      Vcd_Putc (H, C);
   end Vcd_Putc;

   procedure Vcd_Newline is
   begin
      Vcd_Putc (H, Nl);
   end Vcd_Newline;

   procedure Vcd_Putline (Str : String) is
   begin
      Vcd_Put (H, Str);
      Vcd_Newline;
   end Vcd_Putline;

--    procedure Vcd_Put (Str : Ghdl_Str_Len_Type)
--    is
--    begin
--       Put_Str_Len (Vcd_Stream, Str);
--    end Vcd_Put;

   procedure Vcd_Put_I32 (V : Ghdl_I32)
   is
      Str : String (1 .. 11);
      First : Natural;
   begin
      Vstrings.To_String (Str, First, V);
      Vcd_Put (Str (First .. Str'Last));
   end Vcd_Put_I32;

   procedure Vcd_Put_Idcode (N : Vcd_Index_Type)
   is
      Str : String (1 .. 8);
      V, R : Vcd_Index_Type;
      L : Natural;
   begin
      L := 0;
      V := N;
      loop
         R := V mod 93;
         V := V / 93;
         L := L + 1;
         Str (L) := Character'Val (33 + R);
         exit when V = 0;
      end loop;
      Vcd_Put (Str (1 .. L));
   end Vcd_Put_Idcode;

   procedure Vcd_Put_Name (Obj : VhpiHandleT)
   is
      Name : String (1 .. 128);
      Name_Len : Integer;
   begin
      Vhpi_Get_Str (VhpiNameP, Obj, Name, Name_Len);
      if Name_Len <= Name'Last then
         Vcd_Put (Name (1 .. Name_Len));
      else
         --  Truncate.
         Vcd_Put (Name);
      end if;
   end Vcd_Put_Name;

   procedure Vcd_Put_End is
   begin
      Vcd_Putline ("$end");
   end Vcd_Put_End;

   --  Called before elaboration.
   procedure Vcd_Init
   is
   begin
      if H = null then
         return;
      end if;
      if Flag_Vcd_Date then
         Vcd_Putline ("$date");
         Vcd_Put ("  ");
         declare
            type time_t is new Interfaces.Integer_64;
            Cur_Time : time_t;

            function time (Addr : Address) return time_t;
            pragma Import (C, time);

            function ctime (Timep: Address) return Ghdl_C_String;
            pragma Import (C, ctime);

            Ct : Ghdl_C_String;
         begin
            Cur_Time := time (Null_Address);
            Ct := ctime (Cur_Time'Address);
            for I in Positive loop
               exit when Ct (I) = NUL;
               Vcd_Putc (Ct (I));
            end loop;
            -- Note: ctime already append a LF.
         end;
         Vcd_Put_End;
      end if;
      Vcd_Putline ("$version");
      Vcd_Putline ("  GHDL v0");
      Vcd_Put_End;
      Vcd_Putline ("$timescale");
      Vcd_Putline ("  1 fs");
      Vcd_Put_End;
   end Vcd_Init;

   package Vcd_Table is new GNAT.Table
     (Table_Component_Type => Verilog_Wire_Info,
      Table_Index_Type => Vcd_Index_Type,
      Table_Low_Bound => 0,
      Table_Initial => 32,
      Table_Increment => 100);

   procedure Avhpi_Error (Err : AvhpiErrorT)
   is
      pragma Unreferenced (Err);
   begin
      Put_Line ("Vcd.Avhpi_Error!");
      null;
   end Avhpi_Error;

   function Rti_To_Vcd_Kind (Rti : Ghdl_Rti_Access) return Vcd_Var_Kind
   is
      Rti1 : Ghdl_Rti_Access;
   begin
      if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then
         Rti1 := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype;
      else
         Rti1 := Rti;
      end if;

      if Rti1 = Std_Standard_Boolean_RTI_Ptr then
         return Vcd_Bool;
      end if;
      if Rti1 = Std_Standard_Bit_RTI_Ptr then
         return Vcd_Bit;
      end if;
      if Rti1 = Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr then
         return Vcd_Stdlogic;
      end if;
      if Rti1.Kind = Ghdl_Rtik_Type_I32 then
         return Vcd_Integer32;
      end if;
      return Vcd_Bad;
   end Rti_To_Vcd_Kind;

   function Rti_To_Vcd_Kind (Rti : Ghdl_Rtin_Type_Array_Acc)
                            return Vcd_Var_Kind
   is
      It : Ghdl_Rti_Access;
   begin
      if Rti.Nbr_Dim /= 1 then
         return Vcd_Bad;
      end if;
      It := Rti.Indexes (0);
      if It.Kind /= Ghdl_Rtik_Subtype_Scalar then
         return Vcd_Bad;
      end if;
      if To_Ghdl_Rtin_Subtype_Scalar_Acc (It).Basetype.Kind
        /= Ghdl_Rtik_Type_I32
      then
         return Vcd_Bad;
      end if;
      case Rti_To_Vcd_Kind (Rti.Element) is
         when Vcd_Bit =>
            return Vcd_Bitvector;
         when Vcd_Stdlogic =>
            return Vcd_Stdlogic_Vector;
         when others =>
            return Vcd_Bad;
      end case;
   end Rti_To_Vcd_Kind;

   procedure Get_Verilog_Wire (Sig : VhpiHandleT; Info : out Verilog_Wire_Info)
   is
      Sig_Type : VhpiHandleT;
      Sig_Rti : Ghdl_Rtin_Object_Acc;
      Rti : Ghdl_Rti_Access;
      Error : AvhpiErrorT;
      Sig_Addr : Address;
   begin
      Sig_Rti := To_Ghdl_Rtin_Object_Acc (Avhpi_Get_Rti (Sig));

      --  Extract type of the signal.
      Vhpi_Handle (VhpiSubtype, Sig, Sig_Type, Error);
      if Error /= AvhpiErrorOk then
         Avhpi_Error (Error);
         return;
      end if;

      Rti := Avhpi_Get_Rti (Sig_Type);
      Sig_Addr := Avhpi_Get_Address (Sig);
      Info.Kind := Vcd_Bad;
      case Rti.Kind is
         when Ghdl_Rtik_Type_B2
           | Ghdl_Rtik_Type_E8
           | Ghdl_Rtik_Subtype_Scalar =>
            Info.Kind := Rti_To_Vcd_Kind (Rti);
            Info.Addr := Sig_Addr;
            Info.Irange := null;
         when Ghdl_Rtik_Subtype_Array =>
            declare
               St : Ghdl_Rtin_Subtype_Array_Acc;
            begin
               St := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
               Info.Kind := Rti_To_Vcd_Kind (St.Basetype);
               Info.Addr := Sig_Addr;
               Info.Irange := To_Ghdl_Range_Ptr
                 (Loc_To_Addr (St.Common.Depth, St.Bounds,
                               Avhpi_Get_Context (Sig)));
            end;
         when Ghdl_Rtik_Subtype_Array_Ptr =>
            declare
               St : Ghdl_Rtin_Subtype_Array_Acc;
            begin
               St := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
               Info.Kind := Rti_To_Vcd_Kind (St.Basetype);
               Info.Addr := To_Addr_Acc (Sig_Addr).all;
               Info.Irange := To_Ghdl_Range_Ptr
                 (Loc_To_Addr (St.Common.Depth, St.Bounds,
                               Avhpi_Get_Context (Sig)));
            end;
         when Ghdl_Rtik_Type_Array =>
            declare
               Uc : Ghdl_Uc_Array_Acc;
            begin
               Info.Kind := Rti_To_Vcd_Kind
                 (To_Ghdl_Rtin_Type_Array_Acc (Rti));
               Uc := To_Ghdl_Uc_Array_Acc (Sig_Addr);
               Info.Addr := Uc.Base;
               Info.Irange := To_Ghdl_Range_Ptr (Uc.Bounds);
            end;
         when others =>
            Info.Irange := null;
      end case;

      --  Do not allow null-array.
      if Info.Irange /= null and then Info.Irange.I32.Len = 0 then
         Info.Kind := Vcd_Bad;
         Info.Irange := null;
         return;
      end if;

      if Vhpi_Get_Kind (Sig) = VhpiPortDeclK then
         case Vhpi_Get_Mode (Sig) is
            when VhpiInMode
              | VhpiInoutMode
              | VhpiBufferMode
              | VhpiLinkageMode =>
               Info.Val := Vcd_Effective;
            when VhpiOutMode =>
               Info.Val := Vcd_Driving;
            when VhpiErrorMode =>