-- GHDL Run Time (GRT) - VCD generator. -- Copyright (C) 2002 - 2014 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. ------------------------------------------------------------------------------- -- TODO: -- * Fix the following issues : -- + Currently both the top level signals and signals in packages aren't -- visible on the tree view (SST) of gtkwave, but both of them are visible -- when no item is selected in the tree view and are mixed together. -- (Same issue with FST waves.) -- + After calling Vcd_Put_Hierarchy (Pack, Match_List), Avhpi_Error is -- raised several times when no signal paths are provided in a wave option -- file. It has no consequences other than a printed message. -- (Same issue with FST waves.) with System; use System; with Interfaces; with Grt.Stdio; use Grt.Stdio; with Grt.Errors; use Grt.Errors; with Grt.Signals; use Grt.Signals; with Grt.Table; with Grt.Astdio; use Grt.Astdio; with Grt.C; use Grt.C; with Grt.Hooks; use Grt.Hooks; with Grt.Rtis; use Grt.Rtis; with Grt.Rtis_Addr; use Grt.Rtis_Addr; with Grt.Rtis_Utils; use Grt.Rtis_Utils; with Grt.Rtis_Types; use Grt.Rtis_Types; with Grt.Vstrings; with Grt.Wave_Opt; use Grt.Wave_Opt; with Grt.Wave_Opt.Design; use Grt.Wave_Opt.Design; with Grt.Fcvt; with Grt.Options; pragma Elaborate_All (Grt.Table); 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; Stream : FILEs; procedure My_Vcd_Put (Str : String) is R : size_t; pragma Unreferenced (R); begin R := fwrite (Str'Address, Str'Length, 1, Stream); end My_Vcd_Put; procedure My_Vcd_Putc (C : Character) is R : int; pragma Unreferenced (R); begin R := fputc (Character'Pos (C), Stream); end My_Vcd_Putc; procedure My_Vcd_Close is begin fclose (Stream); Stream := NULL_Stream; end My_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 : constant Natural := Opt'First; Mode : constant String := "wt" & NUL; 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 Vcd_Close /= 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; if Vcd_Filename.all = "-" & NUL then Stream := stdout; else Stream := fopen (Vcd_Filename.all'Address, Mode'Address); if Stream = NULL_Stream then Error_S ("cannot open "); Error_E (Vcd_Filename (Vcd_Filename'First .. Vcd_Filename'Last - 1)); return True; end if; end if; Vcd_Putc := My_Vcd_Putc'Access; Vcd_Put := My_Vcd_Put'Access; Vcd_Close := My_Vcd_Close'Access; 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_Newline is begin Vcd_Putc (Nl); end Vcd_Newline; procedure Vcd_Putline (Str : String) is begin Vcd_Put (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 Vcd_Close = 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"); case Options.Time_Resolution_Scale is when 5 => Vcd_Putline (" 1 fs"); when 4 => Vcd_Putline (" 1 ps"); when 3 => Vcd_Putline (" 1 ns"); when 2 => Vcd_Putline (" 1 us"); when 1 => Vcd_Putline (" 1 ms"); when 0 => Vcd_Putline (" 1 sec"); end case; Vcd_Put_End; end Vcd_Init; package Vcd_Table is new Grt.Table (Table_Component_Type => Verilog_Wire_Info, Table_Index_Type => Vcd_Index_Type, Table_Low_Bound => 0, Table_Initial => 32); 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_Type is begin case Rti.Kind is when Ghdl_Rtik_Subtype_Scalar => return Rti_To_Vcd_Kind (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype); when Ghdl_Rtik_Type_B1 => if Rti = Std_Standard_Boolean_RTI_Ptr then return Vcd_Bool; elsif Rti = Std_Standard_Bit_RTI_Ptr then return Vcd_Bit; else return Vcd_Bad; end if; when Ghdl_Rtik_Type_I32 => return Vcd_Integer32; when Ghdl_Rtik_Type_F64 => return Vcd_Float64; when Ghdl_Rtik_Type_E8 => if Rti = Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr then return Vcd_Stdlogic; else return Vcd_Enum8; end if; when others => return Vcd_Bad; end case; end Rti_To_Vcd_Kind; function Rti_To_Vcd_Kind (Rti : Ghdl_Rtin_Type_Array_Acc) return Vcd_Var_Type is It : Ghdl_Rti_Access; begin -- Support only one-dimensional arrays... if Rti.Nbr_Dim /= 1 then return Vcd_Bad; end if; -- ... whose index is a scalar... It := Rti.Indexes (0); if It.Kind /= Ghdl_Rtik_Subtype_Scalar then return Vcd_Bad; end if; -- ... integer. 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; Rti : Ghdl_Rti_Access; Error : AvhpiErrorT; Sig_Addr : Address; Bounds : Address; Kind : Vcd_Var_Type; Irange : Ghdl_Range_Ptr; Val : Vcd_Value_Kind; begin -- 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); Object_To_Base_Bounds (Rti, Sig_Addr, Sig_Addr, Bounds); case Rti.Kind is when Ghdl_Rtik_Type_B1 | Ghdl_Rtik_Type_E8 | Ghdl_Rtik_Subtype_Scalar => Kind := Rti_To_Vcd_Kind (Rti); Irange := null; when Ghdl_Rtik_Subtype_Array => declare St : constant Ghdl_Rtin_Subtype_Composite_Acc := To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); Arr_Rti : constant Ghdl_Rtin_Type_Array_Acc := To_Ghdl_Rtin_Type_Array_Acc (St.Basetype); Idx_Rti : constant Ghdl_Rti_Access := Get_Base_Type (Arr_Rti.Indexes (0)); begin Kind := Rti_To_Vcd_Kind (Arr_Rti); Bounds := Loc_To_Addr (St.Common.Depth, St.Layout, Avhpi_Get_Context (Sig)); Bounds := Array_Layout_To_Bounds (Bounds); Extract_Range (Bounds, Idx_Rti, Irange); end; when Ghdl_Rtik_Type_Array => declare Arr_Rti : constant Ghdl_Rtin_Type_Array_Acc := To_Ghdl_Rtin_Type_Array_Acc (Rti); Idx_Rti : constant Ghdl_Rti_Access := Get_Base_Type (Arr_Rti.Indexes (0)); begin Kind := Rti_To_Vcd_Kind (Arr_Rti); Extract_Range (Bounds, Idx_Rti, Irange); end; when others => Kind := Vcd_Bad; end case; -- Do not allow null-array. if Kind = Vcd_Bad or else (Irange /= null and then Irange.I32.Len = 0) then Info := (Vtype => Vcd_Bad, Val => Vcd_Effective, Ptr => Null_Address); return; end if; case Vhpi_Get_Kind (Sig) is when VhpiPortDeclK => case Vhpi_Get_Mode (Sig) is when VhpiInMode | VhpiInoutMode | VhpiBufferMode | VhpiLinkageMode => Val := Vcd_Effective; when VhpiOutMode => Val := Vcd_Driving; when VhpiErrorMode => Kind := Vcd_Bad; end case; when VhpiSigDeclK => Val := Vcd_Effective; when VhpiGenericDeclK => Val := Vcd_Variable; when others => Info := (Vtype => Vcd_Bad, Val => Vcd_Effective, Ptr => Null_Address); return; end case; case Kind is when Vcd_Bad => Info := (Vcd_Bad, Vcd_Effective, Null_Address); when Vcd_Enum8 => Info := (Vcd_Enum8, Val, Sig_Addr, Rti); when Vcd_Bool => Info := (Vcd_Bool, Val, Sig_Addr); when Vcd_Integer32 => Info := (Vcd_Integer32, Val, Sig_Addr); when Vcd_Float64 => Info := (Vcd_Float64, Val, Sig_Addr); when Vcd_Bit => Info := (Vcd_Bit, Val, Sig_Addr); when Vcd_Stdlogic => Info := (Vcd_Stdlogic, Val, Sig_Addr); when Vcd_Bitvector => Info := (Vcd_Bitvector, Val, Sig_Addr, Irange); when Vcd_Stdlogic_Vector => Info := (Vcd_Stdlogic_Vector, Val, Sig_Addr, Irange); end case; end Get_Verilog_Wire; function Get_Wire_Length (Info : Verilog_Wire_Info) return Ghdl_Index_Type is begin if Info.Vtype in Vcd_Var_Vectors then return Info.Irange.I32.Len; else return 1; end if; end Get_Wire_Length; function Verilog_Wire_Val (Info : Verilog_Wire_Info) return Ghdl_Value_Ptr is begin case Info.Val is when Vcd_Effective => return To_Signal_Arr_Ptr (Info.Ptr)(0).Value_Ptr; when Vcd_Driving => return To_Signal_Arr_Ptr (Info.Ptr)(0).Driving_Value'Access; when Vcd_Variable => return To_Ghdl_Value_Ptr (Info.Ptr); end case; end Verilog_Wire_Val; function Verilog_Wire_Val (Info : Verilog_Wire_Info; Idx : Ghdl_Index_Type) return Ghdl_Value_Ptr is begin case Info.Val is when Vcd_Effective => return To_Signal_Arr_Ptr (Info.Ptr)(Idx).Value_Ptr; when Vcd_Driving => return To_Signal_Arr_Ptr (Info.Ptr)(Idx).Driving_Value'Access; when Vcd_Variable => -- TODO Internal_Error ("verilog_wire_val"); end case; end Verilog_Wire_Val; procedure Add_Signal (Sig : VhpiHandleT) is N : Vcd_Index_Type; Vcd_El : Verilog_Wire_Info; begin Get_Verilog_Wire (Sig, Vcd_El); if Vcd_El.Vtype = Vcd_Bad or else Vcd_El.Vtype = Vcd_Enum8 then Vcd_Put ("$comment "); Vcd_Put_Name (Sig); Vcd_Put (" is not handled"); --Vcd_Put (Ghdl_Type_Kind'Image (Desc.Kind)); Vcd_Putc (' '); Vcd_Put_End; return; else Vcd_Table.Increment_Last; N := Vcd_Table.Last; Vcd_Table.Table (N) := Vcd_El; Vcd_Put ("$var "); case Vcd_El.Vtype is when Vcd_Integer32 => Vcd_Put ("integer 32"); when Vcd_Float64 => Vcd_Put ("real 64"); when Vcd_Bool | Vcd_Bit | Vcd_Stdlogic => Vcd_Put ("reg 1"); when Vcd_Bitvector | Vcd_Stdlogic_Vector => Vcd_Put ("reg "); Vcd_Put_I32 (Ghdl_I32 (Vcd_El.Irange.I32.Len)); when Vcd_Bad | Vcd_Enum8 => null; end case; Vcd_Putc (' '); Vcd_Put_Idcode (N); Vcd_Putc (' '); Vcd_Put_Name (Sig); if Vcd_El.Vtype in Vcd_Var_Vectors then Vcd_Putc ('['); Vcd_Put_I32 (Vcd_El.Irange.I32.Left); Vcd_Putc (':'); Vcd_Put_I32 (Vcd_El.Irange.I32.Right); Vcd_Putc (']'); end if; Vcd_Putc (' '); Vcd_Put_End; if Boolean'(False) then Vcd_Put ("$comment "); Vcd_Put_Name (Sig); Vcd_Put (" is "); case Vcd_El.Val is when Vcd_Effective => Vcd_Put ("effective "); when Vcd_Driving => Vcd_Put ("driving "); when Vcd_Variable => Vcd_Put ("variable "); end case; Vcd_Put_End; end if; end if; end Add_Signal; procedure Vcd_Put_Hierarchy (Inst : VhpiHandleT; Match_List : Design.Match_List) is Decl_It : VhpiHandleT; Decl : VhpiHandleT; Error : AvhpiErrorT; Match_List_Child : Design.Match_List; begin Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error); if Error /= AvhpiErrorOk then Avhpi_Error (Error); return; end if; Vcd_Put ("$scope module "); Vcd_Put_Name (Inst); Vcd_Putc (' '); Vcd_Put_End; -- Extract signals. loop Vhpi_Scan (Decl_It, Decl, Error); exit when Error = AvhpiErrorIteratorEnd; if Error /= AvhpiErrorOk then Avhpi_Error (Error); return; end if; case Vhpi_Get_Kind (Decl) is when VhpiPortDeclK | VhpiSigDeclK => Match_List_Child := Get_Cursor (Match_List, Avhpi_Get_Base_Name (Decl), Is_Signal => True); if Is_Displayed (Match_List_Child) then Add_Signal (Decl); end if; when others => null; end case; end loop; -- Extract sub-scopes. if Vhpi_Get_Kind (Inst) /= VhpiPackInstK then Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error); if Error /= AvhpiErrorOk then Avhpi_Error (Error); return; end if; loop Vhpi_Scan (Decl_It, Decl, Error); exit when Error = AvhpiErrorIteratorEnd; if Error /= AvhpiErrorOk then Avhpi_Error (Error); return; end if; case Vhpi_Get_Kind (Decl) is when VhpiIfGenerateK | VhpiForGenerateK | VhpiBlockStmtK | VhpiCompInstStmtK => Match_List_Child := Get_Cursor (Match_List, Avhpi_Get_Base_Name (Decl)); if Is_Displayed (Match_List_Child) then Vcd_Put_Hierarchy (Decl, Match_List_Child); end if; when others => null; end case; end loop; end if; Vcd_Put ("$upscope "); Vcd_Put_End; end Vcd_Put_Hierarchy; procedure Vcd_Put_Bit (V : Ghdl_B1) is C : Character; begin if V then C := '1'; else C := '0'; end if; Vcd_Putc (C); end Vcd_Put_Bit; procedure Vcd_Put_Stdlogic (V : Ghdl_E8) is type Map_Type is array (Ghdl_E8 range 0 .. 8) of Character; -- "UX01ZWLH-" -- Map_Vlg : constant Map_Type := "xx01zz01x"; Map_Std : constant Map_Type := "UX01ZWLH-"; begin if V not in Map_Type'Range then Vcd_Putc ('?'); else Vcd_Putc (Map_Std (V)); end if; end Vcd_Put_Stdlogic; procedure Vcd_Put_Integer32 (V : Ghdl_U32) is Val : Ghdl_U32; N : Natural; begin Val := V; N := 32; while N > 1 loop exit when (Val and 16#8000_0000#) /= 0; Val := Val * 2; N := N - 1; end loop; while N > 0 loop if (Val and 16#8000_0000#) /= 0 then Vcd_Putc ('1'); else Vcd_Putc ('0'); end if; Val := Val * 2; N := N - 1; end loop; end Vcd_Put_Integer32; procedure Vcd_Put_Float64 (V : Ghdl_F64) is Str : String (1 .. 32); Len : Natural; begin -- IEEE1364 18.2 Format of the four state VCD file -- A real number if dumped using a %.16g printf() format. This -- preserves the precision of that number by outputting all 53 bits in -- the mantissa of a 64-bit IEEE std 754-1985 double-precision number. -- Application programs can read a real number using a %g format to -- scanf(). -- ISO-C 7.19.6.1 The fprintf function -- [...], the maximum number of significant digits for the g and G -- conversions, [...] -- Note: the code always uses the 'e' format, with a full precision. Grt.Fcvt.Format_Image (Str, Len, Interfaces.IEEE_Float_64 (V)); Vcd_Put (Str (1 .. Len)); end Vcd_Put_Float64; procedure Vcd_Put_Var (I : Vcd_Index_Type) is V : Verilog_Wire_Info renames Vcd_Table.Table (I); Len : constant Ghdl_Index_Type := Get_Wire_Length (V); begin case V.Vtype is when Vcd_Bit | Vcd_Bool => Vcd_Put_Bit (Verilog_Wire_Val (V).B1); when Vcd_Stdlogic => Vcd_Put_Stdlogic (Verilog_Wire_Val (V).E8); when Vcd_Integer32 => Vcd_Putc ('b'); Vcd_Put_Integer32 (Verilog_Wire_Val (V).E32); Vcd_Putc (' '); when Vcd_Float64 => Vcd_Putc ('r'); Vcd_Put_Float64 (Verilog_Wire_Val (V).F64); Vcd_Putc (' '); when Vcd_Bitvector => Vcd_Putc ('b'); for J in 0 .. Len - 1 loop Vcd_Put_Bit (Verilog_Wire_Val (V, J).B1); end loop; Vcd_Putc (' '); when Vcd_Stdlogic_Vector => Vcd_Putc ('b'); for J in 0 .. Len - 1 loop Vcd_Put_Stdlogic (Verilog_Wire_Val (V, J).E8); end loop; Vcd_Putc (' '); when Vcd_Bad | Vcd_Enum8 => null; end case; Vcd_Put_Idcode (I); Vcd_Newline; end Vcd_Put_Var; function Verilog_Wire_Changed (Info : Verilog_Wire_Info; Last : Std_Time) return Boolean is begin case Vcd_Value_Signals (Info.Val) is when Vcd_Effective => case Info.Vtype is when Vcd_Bit | Vcd_Bool | Vcd_Enum8 | Vcd_Stdlogic | Vcd_Integer32 | Vcd_Float64 => if To_Signal_Arr_Ptr (Info.Ptr)(0).Last_Event = Last then return True; end if; when Vcd_Bitvector | Vcd_Stdlogic_Vector => for J in 0 .. Info.Irange.I32.Len - 1 loop if To_Signal_Arr_Ptr (Info.Ptr)(J).Last_Event = Last then return True; end if; end loop; when Vcd_Bad => null; end case; when Vcd_Driving => case Info.Vtype is when Vcd_Bit | Vcd_Bool | Vcd_Enum8 | Vcd_Stdlogic | Vcd_Integer32 | Vcd_Float64 => if To_Signal_Arr_Ptr (Info.Ptr)(0).Last_Active = Last then return True; end if; when Vcd_Bitvector | Vcd_Stdlogic_Vector => for J in 0 .. Info.Irange.I32.Len - 1 loop if To_Signal_Arr_Ptr (Info.Ptr)(J).Last_Active = Last then return True; end if; end loop; when Vcd_Bad => null; end case; end case; return False; end Verilog_Wire_Changed; function Verilog_Wire_Event (Info : Verilog_Wire_Info) return Boolean is begin case Info.Vtype is when Vcd_Bit | Vcd_Bool | Vcd_Enum8 | Vcd_Stdlogic | Vcd_Integer32 | Vcd_Float64 => if To_Signal_Arr_Ptr (Info.Ptr)(0).Event then return True; end if; when Vcd_Bitvector | Vcd_Stdlogic_Vector => for J in 0 .. Info.Irange.I32.Len - 1 loop if To_Signal_Arr_Ptr (Info.Ptr)(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 (Current_Time)); Vcd_Put (Str (First .. Str'Last)); Vcd_Newline; end Vcd_Put_Time; procedure Vcd_Cycle; -- Called after elaboration. procedure Vcd_Start is Pack_It : VhpiHandleT; Pack : VhpiHandleT; Error : AvhpiErrorT; Root : VhpiHandleT; Match_List : Design.Match_List; begin -- Do nothing if there is no VCD file to generate. if Vcd_Close = null then return; end if; -- Be sure the RTI of std_ulogic is set. Search_Types_RTI; -- Put hierarchy. -- First packages. Get_Package_Inst (Pack_It); loop Vhpi_Scan (Pack_It, Pack, Error); exit when Error = AvhpiErrorIteratorEnd; if Error /= AvhpiErrorOk then Avhpi_Error (Error); return; end if; Match_List := Get_Top_Cursor (Pkg, Avhpi_Get_Base_Name (Pack)); if Is_Displayed (Match_List) then Vcd_Put_Hierarchy (Pack, Match_List); end if; end loop; -- Then top entity. Get_Root_Inst (Root); Match_List := Get_Top_Cursor (Entity, Avhpi_Get_Base_Name (Root)); if Is_Displayed (Match_List) then Vcd_Put_Hierarchy (Root, Match_List); end if; Wave_Opt.Design.Last_Checks; -- End of header. Vcd_Put ("$enddefinitions "); Vcd_Put_End; Register_Cycle_Hook (Vcd_Cycle'Access); end Vcd_Start; -- Called before each non delta cycle. procedure Vcd_Cycle is begin -- Disp values. Vcd_Put_Time; if Current_Time = 0 then -- Disp all values. for I in Vcd_Table.First .. Vcd_Table.Last loop Vcd_Put_Var (I); end loop; else -- Disp only values changed. for I in Vcd_Table.First .. Vcd_Table.Last loop if Verilog_Wire_Changed (Vcd_Table.Table (I), Current_Time) then Vcd_Put_Var (I); end if; end loop; end if; end Vcd_Cycle; -- Called at the end of the simulation. procedure Vcd_End is begin if Vcd_Close /= null then Vcd_Close.all; end if; end Vcd_End; Vcd_Hooks : aliased constant Hooks_Type := (Desc => new String'("vcd: save waveforms in vcf file format"), Option => Vcd_Option'Access, Help => Vcd_Help'Access, Init => Vcd_Init'Access, Start => Vcd_Start'Access, Finish => Vcd_End'Access); procedure Register is begin Register_Hooks (Vcd_Hooks'Access); end Register; end Grt.Vcd;