--  GHDL Run Time (GRT) - wave dumper (GHW) module.
--  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.

with System; use System;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Interfaces; use Interfaces;
with Grt.Types; use Grt.Types;
with Grt.Avhpi; use Grt.Avhpi;
with Grt.Stdio; use Grt.Stdio;
with Grt.C; use Grt.C;
with Grt.Errors; use Grt.Errors;
with Grt.Astdio; use Grt.Astdio;
with Grt.Callbacks; use Grt.Callbacks;
with Grt.Hooks; use Grt.Hooks;
with Grt.Table;
with Grt.Avls; use Grt.Avls;
with Grt.Rtis; use Grt.Rtis;
with Grt.Rtis_Addr; use Grt.Rtis_Addr;
with Grt.Rtis_Utils;
with Grt.Rtis_Types;
with Grt.Signals; use Grt.Signals;
with Grt.Vstrings; use Grt.Vstrings;
with Grt.Ghw; use Grt.Ghw;
with Grt.Wave_Opt; use Grt.Wave_Opt;
with Grt.Wave_Opt.File; use Grt.Wave_Opt.File;
with Grt.Wave_Opt.Design; use Grt.Wave_Opt.Design;

pragma Elaborate_All (Grt.Rtis_Utils);
pragma Elaborate_All (Grt.Table);

package body Grt.Waves is
   --  Waves filename.
   Wave_Filename : String_Access := null;
   --  Stream corresponding to the GHW filename.
   Wave_Stream : FILEs;

   --  Return TRUE if OPT is an option for wave.
   function Wave_Option (Opt : String) return Boolean
   is
      F : constant Natural := Opt'First;
   begin
      if Opt'Length < 6 or else Opt (F .. F + 5) /= "--wave" then
         return False;
      end if;
      if Opt'Length > 6 and then Opt (F + 6) = '=' then
         --  Add an extra NUL character.
         Wave_Filename := new String (1 .. Opt'Length - 7 + 1);
         Wave_Filename (1 .. Opt'Length - 7) := Opt (F + 7 .. Opt'Last);
         Wave_Filename (Wave_Filename'Last) := NUL;
         return True;
      else
         return False;
      end if;
   end Wave_Option;

   procedure Wave_Help is
   begin
      Put_Line (" --wave=FILENAME    dump signal values into a wave file");
   end Wave_Help;

   procedure Wave_Put (Str : String)
   is
      R : size_t;
      pragma Unreferenced (R);
   begin
      R := fwrite (Str'Address, Str'Length, 1, Wave_Stream);
   end Wave_Put;

   procedure Wave_Putc (C : Character)
   is
      R : int;
      pragma Unreferenced (R);
   begin
      R := fputc (Character'Pos (C), Wave_Stream);
   end Wave_Putc;

   procedure Wave_Newline is
   begin
      Wave_Putc (Nl);
   end Wave_Newline;

   procedure Wave_Put_Byte (B : Unsigned_8)
   is
      V : Unsigned_8 := B;
      R : size_t;
      pragma Unreferenced (R);
   begin
      R := fwrite (V'Address, 1, 1, Wave_Stream);
   end Wave_Put_Byte;

   procedure Wave_Put_ULEB128 (Val : Ghdl_E32)
   is
      V : Ghdl_E32;
      R : Ghdl_E32;
   begin
      V := Val;
      loop
         R := V mod 128;
         V := V / 128;
         if V = 0 then
            Wave_Put_Byte (Unsigned_8 (R));
            exit;
         else
            Wave_Put_Byte (Unsigned_8 (128 + R));
         end if;
      end loop;
   end Wave_Put_ULEB128;

   procedure Wave_Put_SLEB128 (Val : Ghdl_I32)
   is
      function To_Ghdl_U32 is new Ada.Unchecked_Conversion
        (Ghdl_I32, Ghdl_U32);
      V : Ghdl_U32 := To_Ghdl_U32 (Val);

--        function Shift_Right_Arithmetic (Value : Ghdl_U32; Amount : Natural)
--                                        return Ghdl_U32;
--        pragma Import (Intrinsic, Shift_Right_Arithmetic);
      R : Unsigned_8;
   begin
      loop
         R := Unsigned_8 (V mod 128);
         V := Shift_Right_Arithmetic (V, 7);
         if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0)
         then
            Wave_Put_Byte (R);
            exit;
         else
            Wave_Put_Byte (R or 16#80#);
         end if;
      end loop;
   end Wave_Put_SLEB128;

   procedure Wave_Put_LSLEB128 (Val : Ghdl_I64)
   is
      function To_Ghdl_U64 is new Ada.Unchecked_Conversion
        (Ghdl_I64, Ghdl_U64);
      V : Ghdl_U64 := To_Ghdl_U64 (Val);

      R : Unsigned_8;
   begin
      loop
         R := Unsigned_8 (V mod 128);
         V := Shift_Right_Arithmetic (V, 7);
         if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0)
         then
            Wave_Put_Byte (R);
            exit;
         else
            Wave_Put_Byte (R or 16#80#);
         end if;
      end loop;
   end Wave_Put_LSLEB128;

   procedure Wave_Put_I32 (Val : Ghdl_I32)
   is
      V : Ghdl_I32 := Val;
      R : size_t;
      pragma Unreferenced (R);
   begin
      R := fwrite (V'Address, 4, 1, Wave_Stream);
   end Wave_Put_I32;

   procedure Wave_Put_I64 (Val : Ghdl_I64)
   is
      V : Ghdl_I64 := Val;
      R : size_t;
      pragma Unreferenced (R);
   begin
      R := fwrite (V'Address, 8, 1, Wave_Stream);
   end Wave_Put_I64;

   procedure Wave_Put_F64 (F64 : Ghdl_F64)
   is
      V : Ghdl_F64 := F64;
      R : size_t;
      pragma Unreferenced (R);
   begin
      R := fwrite (V'Address, Ghdl_F64'Size / Storage_Unit, 1, Wave_Stream);
   end Wave_Put_F64;

   procedure Wave_Puts (Str : Ghdl_C_String) is
   begin
      Put (Wave_Stream, Str);
   end Wave_Puts;

   procedure Write_Value (Value : Ghdl_Value_Ptr; Mode : Mode_Type) is
   begin
      case Mode is
         when Mode_B1 =>
            Wave_Put_Byte (Ghdl_B1'Pos (Value.B1));
         when Mode_E8 =>
            Wave_Put_Byte (Ghdl_E8'Pos (Value.E8));
         when Mode_E32 =>
            Wave_Put_ULEB128 (Value.E32);
         when Mode_I32 =>
            Wave_Put_SLEB128 (Value.I32);
         when Mode_I64 =>
            Wave_Put_LSLEB128 (Value.I64);
         when Mode_F64 =>
            Wave_Put_F64 (Value.F64);
      end case;
   end Write_Value;

   subtype Section_Name is String (1 .. 4);
   type Header_Type is record
      Name : Section_Name;
      Pos : long;
   end record;

   package Section_Table is new Grt.Table
     (Table_Component_Type => Header_Type,
      Table_Index_Type => Natural,
      Table_Low_Bound => 1,
      Table_Initial => 16);

   --  Create a new section.
   --  Write the header in the file.
   --  Save the location for the directory.
   procedure Wave_Section (Name : Section_Name) is
   begin
      Section_Table.Append (Header_Type'(Name => Name,
                                         Pos => ftell (Wave_Stream)));
      Wave_Put (Name);
   end Wave_Section;

   procedure Wave_Write_Size_Order is
   begin
      --  Byte order, 1 byte.
      --  0: bad, 1 : little-endian, 2 : big endian.
      declare
         type Byte_Arr is array (0 .. 3) of Unsigned_8;
         function To_Byte_Arr is new Ada.Unchecked_Conversion
           (Source => Unsigned_32, Target => Byte_Arr);
         B4 : constant Byte_Arr := To_Byte_Arr (16#11_22_33_44#);
         V : Unsigned_8;
      begin
         if B4 (0) = 16#11# then
            --  Big endian.
            V := 2;
         elsif B4 (0) = 16#44# then
            --  Little endian.
            V := 1;
         else
            --  Unknown endian.
            V := 0;
         end if;
         Wave_Put_Byte (V);
      end;
      --  Word size, 1 byte.
      Wave_Put_Byte (Integer'Size / 8);
      --  File offset size, 1 byte
      Wave_Put_Byte (1);
      --  Unused, must be zero (MBZ).
      Wave_Put_Byte (0);
   end Wave_Write_Size_Order;

   procedure Wave_Write_Directory
   is
      Pos : long;
   begin
      Pos := ftell (Wave_Stream);
      Wave_Section ("DIR" & NUL);
      Wave_Write_Size_Order;
      Wave_Put_I32 (Ghdl_I32 (Section_Table.Last));
      for I in Section_Table.First .. Section_Table.Last loop
         Wave_Put (Section_Table.Table (I).Name);
         Wave_Put_I32 (Ghdl_I32 (Section_Table.Table (I).Pos));
      end loop;
      Wave_Put ("EOD" & NUL);

      Wave_Section ("TAI" & NUL);
      Wave_Write_Size_Order;
      Wave_Put_I32 (Ghdl_I32 (Pos));
   end Wave_Write_Directory;

   --  Called before elaboration.
   procedure Wave_Init
   is
      Mode : constant String := "wb" & NUL;
   begin
      if Wave_Filename = null then
         Wave_Stream := NULL_Stream;
         return;
      end if;
      if Wave_Filename.all = "-" & NUL then
         Wave_Stream := stdout;
      else
         Wave_Stream := fopen (Wave_Filename.all'Address, Mode'Address);
         if Wave_Stream = NULL_Stream then
            Error_S ("cannot open ");
            Error_E (Wave_Filename (Wave_Filename'First
                                   .. Wave_Filename'Last - 1));
            return;
         end if;
      end if;
   end Wave_Init;

   procedure Write_File_Header is
   begin
      --  Magic, 9 bytes.
      Wave_Put ("GHDLwave" & Nl);
      --  Header length.
      Wave_Put_Byte (16);
      --  Version-major, 1 byte.
      Wave_Put_Byte (0);
      --  Version-minor, 1 byte.
      Wave_Put_Byte (1);

      Wave_Write_Size_Order;

      --  TODO: add time resolution.
   end Write_File_Header;

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

   package Str_Table is new Grt.Table
     (Table_Component_Type => Ghdl_C_String,
      Table_Index_Type => AVL_Value,
      Table_Low_Bound => 1,
      Table_Initial => 16);

   package Str_AVL is new Grt.Table
     (Table_Component_Type => AVL_Node,
      Table_Index_Type => AVL_Nid,
      Table_Low_Bound => AVL_Root,
      Table_Initial => 16);

   Strings_Len : Natural := 0;

   function Str_Compare (L, R : AVL_Value) return Integer
   is
      Ls, Rs : Ghdl_C_String;
   begin
      Ls := Str_Table.Table (L);
      Rs := Str_Table.Table (R);
      if L = R then
         return 0;
      end if;
      return Strcmp (Ls, Rs);
   end Str_Compare;

   procedure Disp_Str_Avl (N : AVL_Nid) is
   begin
      Put (stdout, "node: ");
      Put_I32 (stdout, Ghdl_I32 (N));
      New_Line (stdout);
      Put (stdout, " left: ");
      Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Left));
      New_Line (stdout);
      Put (stdout, " right: ");
      Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Right));
      New_Line (stdout);
      Put (stdout, " height: ");
      Put_I32 (stdout, Str_AVL.Table (N).Height);
      New_Line (stdout);
      Put (stdout, " str: ");
      --Put (stdout, Str_AVL.Table (N).Val);
      New_Line (stdout);
   end Disp_Str_Avl;

   pragma Unreferenced (Disp_Str_Avl);

   function Create_Str_Index (Str : Ghdl_C_String) return AVL_Value
   is
      Res : AVL_Nid;
   begin
      Str_Table.Append (Str);
      Str_AVL.Append (AVL_Node'(Val => Str_Table.Last,
                                Left | Right => AVL_Nil,
                                Height => 1));
      Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)),
                Str_Compare'Access,
                Str_AVL.Last, Res);
      if Res /= Str_AVL.Last then
         Str_AVL.Decrement_Last;
         Str_Table.Decrement_Last;
      else
         Strings_Len := Strings_Len + strlen (Str);
      end if;
      return Str_AVL.Table (Res).Val;
   end Create_Str_Index;

   pragma Unreferenced (Create_Str_Index);

   procedure Create_String_Id (Str : Ghdl_C_String)
   is
      Res : AVL_Nid;
   begin
      if Str = null then
         return;
      end if;
      Str_Table.Append (Str);
      Str_AVL.Append (AVL_Node'(Val => Str_Table.Last,
                                Left | Right => AVL_Nil,
                                Height => 1));
      Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)),
                Str_Compare'Access,
                Str_AVL.Last, Res);
      if Res /= Str_AVL.Last then
         Str_AVL.Decrement_Last;
         Str_Table.Decrement_Last;
      else
         Strings_Len := Strings_Len + strlen (Str);
      end if;
   end Create_String_Id;

   function Get_String (Str : Ghdl_C_String) return AVL_Value
   is
      H, L, M : AVL_Value;
      Diff : Integer;
   begin
      L := Str_Table.First;
      H := Str_Table.Last;
      loop
         M := (L + H) / 2;
         Diff := Strcmp (Str, Str_Table.Table (M));
         if Diff = 0 then
            return M;
         elsif Diff < 0 then
            H := M - 1;
         else
            L := M + 1;
         end if;
         exit when L > H;
      end loop;
      return 0;
   end Get_String;

   procedure Write_String_Id (Str : Ghdl_C_String) is
   begin
      if Str = null then
         Wave_Put_Byte (0);
      else
         Wave_Put_ULEB128 (Ghdl_E32 (Get_String (Str)));
      end if;
   end Write_String_Id;

   type Type_Node is record
      Type_Rti : Ghdl_Rti_Access;
      Context : Rti_Context;
   end record;

   package Types_Table is new Grt.Table
     (Table_Component_Type => Type_Node,
      Table_Index_Type => AVL_Value,
      Table_Low_Bound => 1,
      Table_Initial => 16);

   package Types_AVL is new Grt.Table
     (Table_Component_Type => AVL_Node,
      Table_Index_Type => AVL_Nid,
      Table_Low_Bound => AVL_Root,
      Table_Initial => 16);

   function Type_Compare (L, R : AVL_Value) return Integer
   is
      function To_Ia is new
        Ada.Unchecked_Conversion (Ghdl_Rti_Access, Integer_Address);

      function "<" (L, R : Ghdl_Rti_Access) return Boolean is
      begin
         return To_Ia (L) < To_Ia (R);
      end "<";

      Ls : Type_Node renames Types_Table.Table (L);
      Rs : Type_Node renames Types_Table.Table (R);
   begin
      if Ls.Type_Rti /= Rs.Type_Rti then
         if Ls.Type_Rti < Rs.Type_Rti then
            return -1;
         else
            return 1;
         end if;
      end if;
      if Ls.Context.Block /= Rs.Context.Block then
         if Ls.Context.Block < Rs.Context.Block then
            return -1;
         else
            return +1;
         end if;
      end if;
      if Ls.Context.Base /= Rs.Context.Base then
         if Ls.Context.Base < Rs.Context.Base then
            return -1;
         else
            return +1;
         end if;
      end if;
      return 0;
   end Type_Compare;

   --  Try to find type (RTI, CTXT) in the types_AVL table.
   --  The first step is to canonicalize CTXT, so that it is the CTXT of
   --   the type (and not a sub-scope of it).
   procedure Find_Type (Rti : Ghdl_Rti_Access;
                        Ctxt : Rti_Context;
                        N_Ctxt : out Rti_Context;
                        Id : out AVL_Nid)
   is
      Depth : Ghdl_Rti_Depth;
   begin
      case Rti.Kind is
         when Ghdl_Rtik_Type_B1
           | Ghdl_Rtik_Type_E8 =>
            N_Ctxt := Null_Context;
         when Ghdl_Rtik_Port
           | Ghdl_Rtik_Signal =>
            N_Ctxt := Ctxt;
         when others =>
            --  Compute the canonical context.
            if Rti.Max_Depth < Rti.Depth then
               Internal_Error ("grt.waves.find_type");
            end if;
            Depth := Rti.Max_Depth;
            if Depth = 0 or else Ctxt.Block = null then
               N_Ctxt := Null_Context;
            else
               N_Ctxt := Ctxt;
               while N_Ctxt.Block.Depth > Depth loop
                  N_Ctxt := Get_Parent_Context (N_Ctxt);
               end loop;
            end if;
      end case;

      --  If the type is already known, return now.
      --  Otherwise, ID is set to AVL_Nil.
      Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => N_Ctxt));
      Id := Find_Node
        (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)),
         Type_Compare'Access,
         Types_Table.Last);
      Types_Table.Decrement_Last;
   end Find_Type;

   procedure Write_Type_Id (Tid : AVL_Nid) is
   begin
      Wave_Put_ULEB128 (Ghdl_E32 (Types_AVL.Table (Tid).Val));
   end Write_Type_Id;

   procedure Write_Type_Id (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
   is
      N_Ctxt : Rti_Context;
      Res : AVL_Nid;
   begin
      Find_Type (Rti, Ctxt, N_Ctxt, Res);
      if Res = AVL_Nil then
         -- raise Program_Error;
         Internal_Error ("write_type_id");
      end if;
      Write_Type_Id (Res);
   end Write_Type_Id;

   procedure Add_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
   is
      Res : AVL_Nid;
   begin
      --  Then, create the type.
      Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => Ctxt));
      Types_AVL.Append (AVL_Node'(Val => Types_Table.Last,
                                  Left | Right => AVL_Nil,
                                  Height => 1));

      Get_Node
        (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)),
         Type_Compare'Access,
         Types_AVL.Last, Res);
      if Res /= Types_AVL.Last then
         --raise Program_Error;
         Internal_Error ("wave.create_type(2)");
      end if;
   end Add_Type;

   procedure Create_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
   is
      N_Ctxt : Rti_Context;
      Res : AVL_Nid;
   begin
      Find_Type (Rti, Ctxt, N_Ctxt, Res);
      if Res /= AVL_Nil then
         return;
      end if;

      --  First, create all the types it depends on.
      case Rti.Kind is
         when Ghdl_Rtik_Type_B1
           | Ghdl_Rtik_Type_E8 =>
            declare
               Enum : constant Ghdl_Rtin_Type_Enum_Acc :=
                 To_Ghdl_Rtin_Type_Enum_Acc (Rti);
            begin
               Create_String_Id (Enum.Name);
               for I in 1 .. Enum.Nbr loop
                  Create_String_Id (Enum.Names (I - 1));
               end loop;
            end;
         when Ghdl_Rtik_Subtype_Array =>
            declare
               Arr : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                 To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
               B_Ctxt : Rti_Context;
            begin
               Create_String_Id (Arr.Name);
               if Rti_Complex_Type (Rti) then
                  B_Ctxt := Ctxt;
               else
                  B_Ctxt := N_Ctxt;
               end if;
               Create_Type (Arr.Basetype, B_Ctxt);
            end;
         when Ghdl_Rtik_Type_Array =>
            declare
               Arr : constant Ghdl_Rtin_Type_Array_Acc :=
                 To_Ghdl_Rtin_Type_Array_Acc (Rti);
            begin
               Create_String_Id (Arr.Name);
               Create_Type (Arr.Element, N_Ctxt);
               for I in 1 .. Arr.Nbr_Dim loop
                  Create_Type (Arr.Indexes (I - 1), N_Ctxt);
               end loop;
            end;
         when Ghdl_Rtik_Subtype_Scalar =>
            declare
               Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
                 To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
            begin
               Create_String_Id (Sub.Name);
               Create_Type (Sub.Basetype, N_Ctxt);
            end;
         when Ghdl_Rtik_Type_I32
           | Ghdl_Rtik_Type_I64
           | Ghdl_Rtik_Type_F64 =>
            declare
               Base : constant Ghdl_Rtin_Type_Scalar_Acc :=
                 To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
            begin
               Create_String_Id (Base.Name);
            end;
         when Ghdl_Rtik_Type_P32
           | Ghdl_Rtik_Type_P64 =>
            declare
               Base : constant Ghdl_Rtin_Type_Physical_Acc :=
                 To_Ghdl_Rtin_Type_Physical_Acc (Rti);
               Unit_Name : Ghdl_C_String;
            begin
               Create_String_Id (Base.Name);
               for I in 1 .. Base.Nbr loop
                  Unit_Name :=
                    Rtis_Utils.Get_Physical_Unit_Name (Base.Units (I - 1));
                  Create_String_Id (Unit_Name);
               end loop;
            end;
         when Ghdl_Rtik_Type_Record
           |  Ghdl_Rtik_Type_Unbounded_Record =>
            declare
               Rec : constant Ghdl_Rtin_Type_Record_Acc :=
                 To_Ghdl_Rtin_Type_Record_Acc (Rti);
               El : Ghdl_Rtin_Element_Acc;
            begin
               Create_String_Id (Rec.Name);
               for I in 1 .. Rec.Nbrel loop
                  El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1));
                  Create_String_Id (El.Name);
                  Create_Type (El.Eltype, N_Ctxt);
               end loop;
            end;
         when Ghdl_Rtik_Subtype_Record =>
            declare
               Rec : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                 To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
            begin
               Create_String_Id (Rec.Name);
               Create_Type (Rec.Basetype, N_Ctxt);
            end;
         when Ghdl_Rtik_Subtype_Unbounded_Record =>
            --  Only the base type.
            declare
               St : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                 To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
               B_Ctxt : Rti_Context;
            begin
               if Rti_Complex_Type (Rti) then
                  B_Ctxt := Ctxt;
               else
                  B_Ctxt := N_Ctxt;
               end if;
               Create_Type (St.Basetype, B_Ctxt);

               return;
            end;
         when others =>
            Internal_Error ("wave.create_type");
--              Internal_Error ("wave.create_type: does not handle " &
--                             Ghdl_Rtik'Image (Rti.Kind));
      end case;

      --  Then, create the type.
      Add_Type (Rti, N_Ctxt);
   end Create_Type;

   procedure Create_Object_Type (Obj : VhpiHandleT)
   is
      Obj_Type : VhpiHandleT;
      Error : AvhpiErrorT;
      Rti : Ghdl_Rti_Access;
   begin
      --  Extract type of the signal.
      Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error);
      if Error /= AvhpiErrorOk then
         Avhpi_Error (Error);
         return;
      end if;
      Rti := Avhpi_Get_Rti (Obj_Type);
      Create_Type (Rti, Avhpi_Get_Context (Obj_Type));

      --  The the signal type is an unbounded type, also put the object
      --  in the type AVL.  This is for unbounded ports.
      --  The real type will be written to the file.
      case Rti.Kind is
         when Ghdl_Rtik_Type_Array
           | Ghdl_Rtik_Type_Unbounded_Record
           | Ghdl_Rtik_Subtype_Unbounded_Record =>
            Add_Type (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
         when others =>
            null;
      end case;
   end Create_Object_Type;

   procedure Write_Object_Type (Obj : VhpiHandleT)
   is
      Obj_Type : VhpiHandleT;
      Error : AvhpiErrorT;
      Rti : Ghdl_Rti_Access;
   begin
      --  Extract type of the signal.
      Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error);
      if Error /= AvhpiErrorOk then
         Avhpi_Error (Error);
         return;
      end if;
      Rti := Avhpi_Get_Rti (Obj_Type);
      case Rti.Kind is
         when Ghdl_Rtik_Type_Array
           | Ghdl_Rtik_Type_Unbounded_Record
           | Ghdl_Rtik_Subtype_Unbounded_Record =>
            Write_Type_Id (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
         when others =>
            Write_Type_Id (Rti, Avhpi_Get_Context (Obj_Type));
      end case;
   end Write_Object_Type;

   procedure Create_Generate_Type (Gen : VhpiHandleT)
   is
      Iterator : VhpiHandleT;
      Error : AvhpiErrorT;
   begin
      --  Extract the iterator.
      Vhpi_Handle (VhpiIterScheme, Gen, Iterator, Error);
      if Error /= AvhpiErrorOk then
         Avhpi_Error (Error);
         return;
      end if;
      Create_Object_Type (Iterator);
   end Create_Generate_Type;

   procedure Write_Generate_Type_And_Value (Gen : VhpiHandleT)
   is
      Iter : VhpiHandleT;
      Iter_Type : VhpiHandleT;
      Error : AvhpiErrorT;
      Addr : Address;
      Mode : Mode_Type;
      Rti : Ghdl_Rti_Access;
   begin
      --  Extract the iterator.
      Vhpi_Handle (VhpiIterScheme, Gen, Iter, Error);
      if Error /= AvhpiErrorOk then
         Avhpi_Error (Error);
         return;
      end if;
      Write_Object_Type (Iter);

      Vhpi_Handle (VhpiSubtype, Iter, Iter_Type, Error);
      if Error /= AvhpiErrorOk then
         Avhpi_Error (Error);
         return;
      end if;
      Rti := Avhpi_Get_Rti (Iter_Type);
      Addr := Avhpi_Get_Address (Iter);

      case Get_Base_Type (Rti).Kind is
         when Ghdl_Rtik_Type_B1 =>
            Mode := Mode_B1;
         when Ghdl_Rtik_Type_E8 =>
            Mode := Mode_E8;
         when Ghdl_Rtik_Type_E32 =>
            Mode := Mode_E32;
         when Ghdl_Rtik_Type_I32 =>
            Mode := Mode_I32;
         when Ghdl_Rtik_Type_I64 =>
            Mode := Mode_I64;
         when Ghdl_Rtik_Type_F64 =>
            Mode := Mode_F64;
         when others =>
            Internal_Error ("bad iterator type");
      end case;
      Write_Value (To_Ghdl_Value_Ptr (Addr), Mode);
   end Write_Generate_Type_And_Value;

   type Step_Type is (Step_Name, Step_Hierarchy);

   Nbr_Scopes : Natural := 0;
   Nbr_Scope_Signals : Natural := 0;
   Nbr_Dumped_Signals : Natural := 0;

   --  This is only valid during write_hierarchy.
   function Get_Signal_Number (Sig : Ghdl_Signal_Ptr) return Natural
   is
      function To_Integer_Address is new Ada.Unchecked_Conversion
        (Ghdl_Signal_Ptr, Integer_Address);
   begin
      return Natural (To_Integer_Address (Sig.Alink));
   end Get_Signal_Number;

   procedure Write_Signal_Number (Val_Addr : Address;
                                  Val_Name : Vstring;
                                  Val_Type : Ghdl_Rti_Access;
                                  Param_Type : Natural)
   is
      pragma Unreferenced (Val_Name);
      pragma Unreferenced (Val_Type);
      pragma Unreferenced (Param_Type);

      Num : Natural;

      function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion
        (Source => Integer_Address, Target => Ghdl_Signal_Ptr);
      Sig : Ghdl_Signal_Ptr;
   begin
      --  Convert to signal.
      Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);

      --  Get signal number.
      Num := Get_Signal_Number (Sig);

      --  If the signal number is 0, then assign a valid signal number.
      if Num = 0 then
         Nbr_Dumped_Signals := Nbr_Dumped_Signals + 1;
         Sig.Alink := To_Ghdl_Signal_Ptr
           (Integer_Address (Nbr_Dumped_Signals));
         Num := Nbr_Dumped_Signals;
      end if;

      --  Do the real job: write the signal number.
      Wave_Put_ULEB128 (Ghdl_E32 (Num));
   end Write_Signal_Number;

   procedure Foreach_Scalar_Signal_Number is new
     Grt.Rtis_Utils.Foreach_Scalar (Param_Type => Natural,
                                    Process => Write_Signal_Number);

   procedure Write_Signal_Numbers (Decl : VhpiHandleT)
   is
      Ctxt : Rti_Context;
      Sig : Ghdl_Rtin_Object_Acc;
   begin
      Ctxt := Avhpi_Get_Context (Decl);
      Sig := To_Ghdl_Rtin_Object_Acc (Avhpi_Get_Rti (Decl));
      Foreach_Scalar_Signal_Number
        (Ctxt, Sig.Obj_Type,
         Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, 0);
   end Write_Signal_Numbers;

   procedure Write_Hierarchy_El (Decl : VhpiHandleT)
   is
      Mode2hie : constant array (VhpiModeT) of Unsigned_8 :=
        (VhpiErrorMode => Ghw_Hie_Signal,
         VhpiInMode => Ghw_Hie_Port_In,
         VhpiOutMode => Ghw_Hie_Port_Out,
         VhpiInoutMode => Ghw_Hie_Port_Inout,
         VhpiBufferMode => Ghw_Hie_Port_Buffer,
         VhpiLinkageMode => Ghw_Hie_Port_Linkage);
      V : Unsigned_8;
   begin
      case Vhpi_Get_Kind (Decl) is
         when VhpiPortDeclK =>
            V := Mode2hie (Vhpi_Get_Mode (Decl));
         when VhpiSigDeclK =>
            V := Ghw_Hie_Signal;
         when VhpiForGenerateK =>
            V := Ghw_Hie_Generate_For;
         when VhpiIfGenerateK =>
            V := Ghw_Hie_Generate_If;
         when VhpiBlockStmtK =>
            V := Ghw_Hie_Block;
         when VhpiCompInstStmtK =>
            V := Ghw_Hie_Instance;
         when VhpiProcessStmtK =>
            V := Ghw_Hie_Process;
         when VhpiPackInstK =>
            V := Ghw_Hie_Package;
         when VhpiRootInstK =>
            V := Ghw_Hie_Instance;
         when others =>
            --raise Program_Error;
            Internal_Error ("write_hierarchy_el");
      end case;
      Wave_Put_Byte (V);
      Write_String_Id (Avhpi_Get_Base_Name (Decl));
      case Vhpi_Get_Kind (Decl) is
         when VhpiPortDeclK
           | VhpiSigDeclK =>
            Write_Object_Type (Decl);
            Write_Signal_Numbers (Decl);
         when VhpiForGenerateK =>
            Write_Generate_Type_And_Value (Decl);
         when others =>
            null;
      end case;
   end Write_Hierarchy_El;

   --  Create a hierarchy block.
   procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT;
                                       Step : Step_Type;
                                       Match_List : Design.Match_List);

   procedure Wave_Put_Hierarchy_1
     (Inst : VhpiHandleT; Step : Step_Type; 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;

      --  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
                  case Step is
                     when Step_Name =>
                        Create_String_Id (Avhpi_Get_Base_Name (Decl));
                        Nbr_Scope_Signals := Nbr_Scope_Signals + 1;
                        Create_Object_Type (Decl);
                     when Step_Hierarchy =>
                        Write_Hierarchy_El (Decl);
                  end case;
               end if;
               --Wave_Put_Name (Decl);
               --Wave_Newline;
            when others =>
               null;
         end case;
      end loop;

      --  No sub-scopes for packages.
      if Vhpi_Get_Kind (Inst) = VhpiPackInstK then
         return;
      end if;

      --  Extract sub-scopes.
      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;

         Nbr_Scopes := Nbr_Scopes + 1;

         Match_List_Child := Get_Cursor
           (Match_List, Avhpi_Get_Base_Name (Decl));
         if Is_Displayed (Match_List_Child) then
            case Vhpi_Get_Kind (Decl) is
               when VhpiIfGenerateK
                 | VhpiForGenerateK
                 | VhpiBlockStmtK
                 | VhpiCompInstStmtK =>
                  Wave_Put_Hierarchy_Block (Decl, Step, Match_List_Child);
               when VhpiProcessStmtK =>
                  case Step is
                     when Step_Name =>
                        Create_String_Id (Avhpi_Get_Base_Name (Decl));
                     when Step_Hierarchy =>
                        Write_Hierarchy_El (Decl);
                  end case;
               when others =>
                  Internal_Error ("wave_put_hierarchy_1");
   --                 Wave_Put ("unknown ");
   --                 Wave_Put (VhpiClassKindT'Image (Vhpi_Get_Kind (Decl)));
   --                 Wave_Newline;
            end case;
         end if;
      end loop;
   end Wave_Put_Hierarchy_1;

   procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT;
                                       Step : Step_Type;
                                       Match_List : Design.Match_List) is
   begin
      case Step is
         when Step_Name =>
            Create_String_Id (Avhpi_Get_Base_Name (Inst));
            if Vhpi_Get_Kind (Inst) = VhpiForGenerateK then
               Create_Generate_Type (Inst);
            end if;
         when Step_Hierarchy =>
            Write_Hierarchy_El (Inst);
      end case;

      Wave_Put_Hierarchy_1 (Inst, Step, Match_List);

      if Step = Step_Hierarchy then
         Wave_Put_Byte (Ghw_Hie_Eos);
      end if;
   end Wave_Put_Hierarchy_Block;

   procedure Wave_Put_Hierarchy (Root : VhpiHandleT; Step : Step_Type)
   is
      Pack_It : VhpiHandleT;
      Pack : VhpiHandleT;
      Error : AvhpiErrorT;
      Match_List : Design.Match_List;
   begin
      --  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
            Wave_Put_Hierarchy_Block (Pack, Step, Match_List);
         end if;
      end loop;

      --  Then top entity.
      Match_List := Get_Top_Cursor (Entity, Avhpi_Get_Base_Name (Root));
      if Is_Displayed (Match_List) then
         Wave_Put_Hierarchy_Block (Root, Step, Match_List);
      end if;
   end Wave_Put_Hierarchy;

   procedure Disp_Str_AVL (Str : AVL_Nid; Indent : Natural)
   is
   begin
      if Str = AVL_Nil then
         return;
      end if;
      Disp_Str_AVL (Str_AVL.Table (Str).Left, Indent + 1);
      for I in 1 .. Indent loop
         Wave_Putc (' ');
      end loop;
      Wave_Puts (Str_Table.Table (Str_AVL.Table (Str).Val));
--        Wave_Putc ('(');
--        Put_I32 (Wave_Stream, Ghdl_I32 (Str));
--        Wave_Putc (')');
--        Put_I32 (Wave_Stream, Get_Height (Str));
      Wave_Newline;
      Disp_Str_AVL (Str_AVL.Table (Str).Right, Indent + 1);
   end Disp_Str_AVL;

   procedure Write_Strings
   is
   begin
--        Wave_Put ("AVL height: ");
--        Put_I32 (Wave_Stream, Ghdl_I32 (Check_AVL (Str_Root)));
--        Wave_Newline;
      Wave_Put ("strings length: ");
      Put_I32 (Wave_Stream, Ghdl_I32 (Strings_Len));
      Wave_Newline;
      Disp_Str_AVL (AVL_Root, 0);
      fflush (Wave_Stream);
   end Write_Strings;

   pragma Unreferenced (Write_Strings);

   procedure Freeze_Strings
   is
      type Str_Table1_Type is array (1 .. Str_Table.Last) of Ghdl_C_String;
      type Str_Table1_Acc is access Str_Table1_Type;
      Idx : AVL_Value;
      Table1 : Str_Table1_Acc;

      procedure Free is new Ada.Unchecked_Deallocation
        (Str_Table1_Type, Str_Table1_Acc);

      procedure Store_Strings (N : AVL_Nid) is
      begin
         if N = AVL_Nil then
            return;
         end if;
         Store_Strings (Str_AVL.Table (N).Left);
         Table1 (Idx) := Str_Table.Table (Str_AVL.Table (N).Val);
         Idx := Idx + 1;
         Store_Strings (Str_AVL.Table (N).Right);
      end Store_Strings;
   begin
      Table1 := new Str_Table1_Type;
      Idx := 1;
      Store_Strings (AVL_Root);
      Str_Table.Release;
      Str_AVL.Free;
      for I in Table1.all'Range loop
         Str_Table.Table (I) := Table1 (I);
      end loop;
      Free (Table1);
   end Freeze_Strings;

   procedure Write_Strings_Compress
   is
      Last : Ghdl_C_String;
      V : Ghdl_C_String;
      L : Natural;
      L1 : Natural;
   begin
      Wave_Section ("STR" & NUL);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_I32 (Ghdl_I32 (Str_Table.Last));
      Wave_Put_I32 (Ghdl_I32 (Strings_Len));
      for I in Str_Table.First .. Str_Table.Last loop
         V := Str_Table.Table (I);
         if I = Str_Table.First then
            L := 1;
         else
            Last := Str_Table.Table (I - 1);

            for I in Positive loop
               if V (I) /= Last (I) then
                  L := I;
                  exit;
               end if;
            end loop;
            L1 := L - 1;
            loop
               if L1 >= 32 then
                  Wave_Put_Byte (Unsigned_8 (L1 mod 32) + 16#80#);
               else
                  Wave_Put_Byte (Unsigned_8 (L1 mod 32));
               end if;
               L1 := L1 / 32;
               exit when L1 = 0;
            end loop;
         end if;

         if Boolean'(False) then
            Put ("string ");
            Put_I32 (stdout, Ghdl_I32 (I));
            Put (": ");
            Put (V);
            New_Line;
         end if;

         loop
            exit when V (L) = NUL;
            Wave_Putc (V (L));
            L := L + 1;
         end loop;
      end loop;
      --  Last string length.
      Wave_Put_Byte (0);
      --  End marker.
      Wave_Put ("EOS" & NUL);
   end Write_Strings_Compress;

   --  Convert rtik (for types).
   function Ghdl_Rtik_To_Ghw_Rtik (Kind : Ghdl_Rtik) return Ghw_Rtik is
   begin
      case Kind is
         when Ghdl_Rtik_Type_B1 =>
            return Ghw_Rtik_Type_B2;
         when Ghdl_Rtik_Type_E8 =>
            return Ghw_Rtik_Type_E8;
         when Ghdl_Rtik_Subtype_Array =>
            return Ghw_Rtik_Subtype_Array;
         when Ghdl_Rtik_Type_Array =>
            return Ghw_Rtik_Type_Array;
         when Ghdl_Rtik_Type_Record
           | Ghdl_Rtik_Type_Unbounded_Record =>
            return Ghw_Rtik_Type_Record;
         when Ghdl_Rtik_Subtype_Record =>
            return Ghw_Rtik_Subtype_Record;
         when Ghdl_Rtik_Subtype_Scalar =>
            return Ghw_Rtik_Subtype_Scalar;
         when Ghdl_Rtik_Type_I32 =>
            return Ghw_Rtik_Type_I32;
         when Ghdl_Rtik_Type_I64 =>
            return Ghw_Rtik_Type_I64;
         when Ghdl_Rtik_Type_F64 =>
            return Ghw_Rtik_Type_F64;
         when Ghdl_Rtik_Type_P32 =>
            return Ghw_Rtik_Type_P32;
         when Ghdl_Rtik_Type_P64 =>
            return Ghw_Rtik_Type_P64;
         when others =>
            return Ghw_Rtik_Error;
      end case;
   end Ghdl_Rtik_To_Ghw_Rtik;

   procedure Write_Range (Rti : Ghdl_Rti_Access; Rng : Ghdl_Range_Ptr)
   is
      Kind : Ghdl_Rtik;
      K : Unsigned_8;
   begin
      Kind := Rti.Kind;
      if Kind = Ghdl_Rtik_Subtype_Scalar then
         Kind := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype.Kind;
      end if;
      K := Ghw_Rtik'Pos (Ghdl_Rtik_To_Ghw_Rtik (Kind));
      case Kind is
         when Ghdl_Rtik_Type_B1 =>
            Wave_Put_Byte (K + Ghdl_Dir_Type'Pos (Rng.B1.Dir) * 16#80#);
            Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Left));
            Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Right));
         when Ghdl_Rtik_Type_E8 =>
            Wave_Put_Byte (K + Ghdl_Dir_Type'Pos (Rng.E8.Dir) * 16#80#);
            Wave_Put_Byte (Unsigned_8 (Rng.E8.Left));
            Wave_Put_Byte (Unsigned_8 (Rng.E8.Right));
         when Ghdl_Rtik_Type_I32
           | Ghdl_Rtik_Type_P32 =>
            Wave_Put_Byte (K + Ghdl_Dir_Type'Pos (Rng.I32.Dir) * 16#80#);
            Wave_Put_SLEB128 (Rng.I32.Left);
            Wave_Put_SLEB128 (Rng.I32.Right);
         when Ghdl_Rtik_Type_P64
           | Ghdl_Rtik_Type_I64 =>
            Wave_Put_Byte (K + Ghdl_Dir_Type'Pos (Rng.P64.Dir) * 16#80#);
            Wave_Put_LSLEB128 (Rng.P64.Left);
            Wave_Put_LSLEB128 (Rng.P64.Right);
         when Ghdl_Rtik_Type_F64 =>
            Wave_Put_Byte (K + Ghdl_Dir_Type'Pos (Rng.F64.Dir) * 16#80#);
            Wave_Put_F64 (Rng.F64.Left);
            Wave_Put_F64 (Rng.F64.Right);
         when others =>
            Internal_Error ("waves.write_range: unhandled kind");
            --Internal_Error ("waves.write_range: unhandled kind "
            --                & Ghdl_Rtik'Image (Kind));
      end case;
   end Write_Range;

   procedure Write_Array_Bounds (Arr : Ghdl_Rtin_Type_Array_Acc;
                                 Bounds : Address)
   is
      Rng : Ghdl_Range_Ptr;
      Index_Type : Ghdl_Rti_Access;
      Bounds1 : Address;
   begin
      Bounds1 := Bounds;
      for I in 0 .. Arr.Nbr_Dim - 1 loop
         Index_Type := Get_Base_Type (Arr.Indexes (I));
         Extract_Range (Bounds1, Index_Type, Rng);
         Write_Range (Index_Type, Rng);
      end loop;
   end Write_Array_Bounds;

   procedure Write_Record_Bounds (Rec : Ghdl_Rtin_Type_Record_Acc;
                                  Layout : Address)
   is
      El : Ghdl_Rtin_Element_Acc;
   begin
      for I in 1 .. Rec.Nbrel loop
         El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1));
         case El.Eltype.Kind is
            when Ghdl_Rtik_Type_Array =>
               Write_Array_Bounds
                 (To_Ghdl_Rtin_Type_Array_Acc (El.Eltype),
                  Array_Layout_To_Bounds (Layout + El.Layout_Off));
            when Ghdl_Rtik_Type_Unbounded_Record =>
               Write_Record_Bounds
                 (To_Ghdl_Rtin_Type_Record_Acc (El.Eltype),
                  Layout + El.Layout_Off);
            when others =>
               null;
         end case;
      end loop;
   end Write_Record_Bounds;

   procedure Write_Types
   is
      Rti : Ghdl_Rti_Access;
      Ctxt : Rti_Context;
   begin
      --  Types header.
      Wave_Section ("TYP" & NUL);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_I32 (Ghdl_I32 (Types_Table.Last));

      for I in Types_Table.First .. Types_Table.Last loop
         Rti := Types_Table.Table (I).Type_Rti;
         Ctxt := Types_Table.Table (I).Context;

         if Rti.Kind = Ghdl_Rtik_Signal or Rti.Kind = Ghdl_Rtik_Port then
            --  Declare types for unbounded objects.
            declare
               Obj_Rti : constant Ghdl_Rtin_Object_Acc :=
                 To_Ghdl_Rtin_Object_Acc (Rti);
            begin
               case Obj_Rti.Obj_Type.Kind is
                  when Ghdl_Rtik_Type_Array =>
                     declare
                        Arr : constant Ghdl_Rtin_Type_Array_Acc :=
                          To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type);
                        Addr : Ghdl_Uc_Array_Acc;
                        Bounds : Address;
                     begin
                        Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Array));
                        Write_String_Id (null);
                        Write_Type_Id (Obj_Rti.Obj_Type, Ctxt);
                        Addr := To_Ghdl_Uc_Array_Acc
                          (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt));
                        Bounds := Addr.Bounds;
                        Write_Array_Bounds (Arr, Bounds);
                     end;
                  when Ghdl_Rtik_Type_Unbounded_Record =>
                     declare
                        Rec : constant Ghdl_Rtin_Type_Record_Acc :=
                          To_Ghdl_Rtin_Type_Record_Acc (Obj_Rti.Obj_Type);
                        Addr : Ghdl_Uc_Array_Acc;
                     begin
                        Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Record));
                        Write_String_Id (null);
                        Write_Type_Id (Obj_Rti.Obj_Type, Ctxt);
                        Addr := To_Ghdl_Uc_Array_Acc
                          (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt));
                        Write_Record_Bounds (Rec, Addr.Bounds);
                     end;
                  when Ghdl_Rtik_Subtype_Unbounded_Record =>
                     declare
                        St : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                          To_Ghdl_Rtin_Subtype_Composite_Acc
                          (Obj_Rti.Obj_Type);
                        Rec : constant Ghdl_Rtin_Type_Record_Acc :=
                          To_Ghdl_Rtin_Type_Record_Acc (St.Basetype);
                        Addr : Ghdl_Uc_Array_Acc;
                     begin
                        Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Record));
                        Write_String_Id (null);
                        Write_Type_Id (St.Basetype, Ctxt);
                        Addr := To_Ghdl_Uc_Array_Acc
                          (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt));
                        Write_Record_Bounds (Rec, Addr.Bounds);
                     end;
                  when others =>
                     Internal_Error ("waves.write_types: unhandled obj kind");
               end case;
            end;
         else
            --  Kind.
            Wave_Put_Byte (Ghw_Rtik'Pos (Ghdl_Rtik_To_Ghw_Rtik (Rti.Kind)));

            case Rti.Kind is
               when Ghdl_Rtik_Type_B1
                 | Ghdl_Rtik_Type_E8 =>
                  declare
                     Enum : constant Ghdl_Rtin_Type_Enum_Acc :=
                       To_Ghdl_Rtin_Type_Enum_Acc (Rti);
                  begin
                     Write_String_Id (Enum.Name);
                     Wave_Put_ULEB128 (Ghdl_E32 (Enum.Nbr));
                     for I in 1 .. Enum.Nbr loop
                        Write_String_Id (Enum.Names (I - 1));
                     end loop;
                  end;
               when Ghdl_Rtik_Subtype_Array =>
                  declare
                     Arr : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                       To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
                  begin
                     Write_String_Id (Arr.Name);
                     Write_Type_Id (Arr.Basetype, Ctxt);
                     declare
                        Bt : constant Ghdl_Rtin_Type_Array_Acc :=
                          To_Ghdl_Rtin_Type_Array_Acc (Arr.Basetype);
                        Layout : Address;
                     begin
                        Layout := Loc_To_Addr (Rti.Depth, Arr.Layout, Ctxt);
                        Write_Array_Bounds
                          (Bt, Array_Layout_To_Bounds (Layout));
                     end;
                  end;
               when Ghdl_Rtik_Type_Array =>
                  declare
                     Arr : constant Ghdl_Rtin_Type_Array_Acc :=
                       To_Ghdl_Rtin_Type_Array_Acc (Rti);
                  begin
                     Write_String_Id (Arr.Name);
                     Write_Type_Id (Arr.Element, Ctxt);
                     Wave_Put_ULEB128 (Ghdl_E32 (Arr.Nbr_Dim));
                     for I in 1 .. Arr.Nbr_Dim loop
                        Write_Type_Id (Arr.Indexes (I - 1), Ctxt);
                     end loop;
                  end;
               when Ghdl_Rtik_Type_Record
                 | Ghdl_Rtik_Type_Unbounded_Record =>
                  declare
                     Rec : constant Ghdl_Rtin_Type_Record_Acc :=
                       To_Ghdl_Rtin_Type_Record_Acc (Rti);
                     El : Ghdl_Rtin_Element_Acc;
                  begin
                     Write_String_Id (Rec.Name);
                     Wave_Put_ULEB128 (Ghdl_E32 (Rec.Nbrel));
                     for I in 1 .. Rec.Nbrel loop
                        El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1));
                        Write_String_Id (El.Name);
                        Write_Type_Id (El.Eltype, Ctxt);
                     end loop;
                  end;
               when Ghdl_Rtik_Subtype_Record =>
                  declare
                     Rec : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                       To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
                     Base : constant Ghdl_Rtin_Type_Record_Acc :=
                       To_Ghdl_Rtin_Type_Record_Acc (Rec.Basetype);
                     Layout : Address;
                  begin
                     Write_String_Id (Rec.Name);
                     Write_Type_Id (Rec.Basetype, Ctxt);
                     if Base.Common.Kind = Ghdl_Rtik_Type_Unbounded_Record then
                        Layout := Loc_To_Addr
                          (Rec.Common.Depth, Rec.Layout, Ctxt);
                        Write_Record_Bounds (Base, Layout);
                     end if;
                  end;
               when Ghdl_Rtik_Subtype_Unbounded_Record =>
                  declare
                     Rec : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                       To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
                  begin
                     Write_String_Id (Rec.Name);
                     Write_Type_Id (Rec.Basetype, Ctxt);
                  end;
               when Ghdl_Rtik_Subtype_Scalar =>
                  declare
                     Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
                       To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
                  begin
                     Write_String_Id (Sub.Name);
                     Write_Type_Id (Sub.Basetype, Ctxt);
                     Write_Range
                       (Sub.Basetype,
                        To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth,
                                                        Sub.Range_Loc,
                                                        Ctxt)));
                  end;
               when Ghdl_Rtik_Type_I32
                 | Ghdl_Rtik_Type_I64
                 | Ghdl_Rtik_Type_F64 =>
                  declare
                     Base : constant Ghdl_Rtin_Type_Scalar_Acc :=
                       To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
                  begin
                     Write_String_Id (Base.Name);
                  end;
               when Ghdl_Rtik_Type_P32
                 | Ghdl_Rtik_Type_P64 =>
                  declare
                     Base : constant Ghdl_Rtin_Type_Physical_Acc :=
                       To_Ghdl_Rtin_Type_Physical_Acc (Rti);
                     Unit : Ghdl_Rti_Access;
                  begin
                     Write_String_Id (Base.Name);
                     Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr));
                     for I in 1 .. Base.Nbr loop
                        Unit := Base.Units (I - 1);
                        Write_String_Id
                          (Rtis_Utils.Get_Physical_Unit_Name (Unit));
                        case Unit.Kind is
                           when Ghdl_Rtik_Unit64 =>
                              Wave_Put_LSLEB128
                                (To_Ghdl_Rtin_Unit64_Acc (Unit).Value);
                           when Ghdl_Rtik_Unitptr =>
                              case Rti.Kind is
                                 when Ghdl_Rtik_Type_P64 =>
                                    Wave_Put_LSLEB128
                                      (To_Ghdl_Rtin_Unitptr_Acc (Unit).
                                         Addr.I64);
                                 when Ghdl_Rtik_Type_P32 =>
                                    Wave_Put_SLEB128
                                      (To_Ghdl_Rtin_Unitptr_Acc (Unit).
                                         Addr.I32);
                                 when others =>
                                    Internal_Error
                                      ("wave.write_types(P32/P64-1)");
                              end case;
                           when others =>
                              Internal_Error
                                ("wave.write_types(P32/P64-2)");
                        end case;
                     end loop;
                  end;
               when others =>
                  Internal_Error ("wave.write_types");
                  --   Internal_Error ("wave.write_types: does not handle " &
                  --                   Ghdl_Rtik'Image (Rti.Kind));
            end case;
         end if;
      end loop;
      Wave_Put_Byte (0);
   end Write_Types;

   procedure Write_Known_Types
   is
      use Grt.Rtis_Types;

      Boolean_Type_Id : AVL_Nid;
      Bit_Type_Id : AVL_Nid;
      Std_Ulogic_Type_Id : AVL_Nid;

      function Search_Type_Id (Rti : Ghdl_Rti_Access) return AVL_Nid
      is
         Ctxt : Rti_Context;
         Tid : AVL_Nid;
      begin
         Find_Type (Rti, Null_Context, Ctxt, Tid);
         return Tid;
      end Search_Type_Id;
   begin
      Search_Types_RTI;

      Boolean_Type_Id := Search_Type_Id (Std_Standard_Boolean_RTI_Ptr);

      Bit_Type_Id := Search_Type_Id (Std_Standard_Bit_RTI_Ptr);

      if Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr /= null then
         Std_Ulogic_Type_Id := Search_Type_Id
           (Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr);
      else
         Std_Ulogic_Type_Id := AVL_Nil;
      end if;

      Wave_Section ("WKT" & NUL);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);

      if Boolean_Type_Id /= AVL_Nil then
         Wave_Put_Byte (1);
         Write_Type_Id (Boolean_Type_Id);
      end if;

      if Bit_Type_Id /= AVL_Nil then
         Wave_Put_Byte (2);
         Write_Type_Id (Bit_Type_Id);
      end if;

      if Std_Ulogic_Type_Id /= AVL_Nil then
         Wave_Put_Byte (3);
         Write_Type_Id (Std_Ulogic_Type_Id);
      end if;

      Wave_Put_Byte (0);
   end Write_Known_Types;

   --  Table of signals to be dumped.
   package Dump_Table is new Grt.Table
     (Table_Component_Type => Ghdl_Signal_Ptr,
      Table_Index_Type => Natural,
      Table_Low_Bound => 1,
      Table_Initial => 32);

   function Get_Dump_Entry (N : Natural) return Ghdl_Signal_Ptr is
   begin
      return Dump_Table.Table (N);
   end Get_Dump_Entry;

   pragma Unreferenced (Get_Dump_Entry);

   procedure Write_Hierarchy (Root : VhpiHandleT)
   is
      N : Natural;
   begin
      --  Check Alink is 0.
      for I in Sig_Table.First .. Sig_Table.Last loop
         if Sig_Table.Table (I).Alink /= null then
            Internal_Error ("wave.write_hierarchy");
         end if;
      end loop;

      Wave_Section ("HIE" & NUL);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_I32 (Ghdl_I32 (Nbr_Scopes));
      Wave_Put_I32 (Ghdl_I32 (Nbr_Scope_Signals));
      Wave_Put_I32 (Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1));
      Wave_Put_Hierarchy (Root, Step_Hierarchy);
      Wave_Put_Byte (0);

      Dump_Table.Set_Last (Nbr_Dumped_Signals);
      for I in Dump_Table.First .. Dump_Table.Last loop
         Dump_Table.Table (I) := null;
      end loop;

      --  Save and clear.
      for I in Sig_Table.First .. Sig_Table.Last loop
         N := Get_Signal_Number (Sig_Table.Table (I));
         if N /= 0 then
            if Dump_Table.Table (N) /= null then
               Internal_Error ("wave.write_hierarchy(2)");
            end if;
            Dump_Table.Table (N) := Sig_Table.Table (I);
            Sig_Table.Table (I).Alink := null;
         end if;
      end loop;
   end Write_Hierarchy;

   procedure Write_Signal_Value (Sig : Ghdl_Signal_Ptr) is
   begin
      --  FIXME: for some signals, the significant value is the driving value!
      Write_Value (Sig.Value_Ptr, Sig.Mode);
   end Write_Signal_Value;

   procedure Write_Snapshot is
   begin
      Wave_Section ("SNP" & NUL);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_Byte (0);
      Wave_Put_I64 (Ghdl_I64 (Current_Time));

      for I in Dump_Table.First .. Dump_Table.Last loop
         Write_Signal_Value (Dump_Table.Table (I));
      end loop;
      Wave_Put ("ESN" & NUL);
   end Write_Snapshot;

   procedure Wave_Start_Cb (Arg : System.Address)
   is
      pragma Unreferenced (Arg);
   begin
      Write_Snapshot;
   end Wave_Start_Cb;

   procedure Wave_Cycle;

   --  Called after elaboration.
   procedure Wave_Start
   is
      Root : VhpiHandleT;
      H : Callback_Handle;
   begin
      --  Do nothing if there is no VCD file to generate.
      if Wave_Stream = NULL_Stream then
         return;
      end if;

      Write_File_Header;

      --  FIXME: write infos
      --  * date
      --  * timescale
      --  * design name ?
      --  ...

      --  Put hierarchy.
      Get_Root_Inst (Root);
      -- Vcd_Search_Packages;
      Wave_Put_Hierarchy (Root, Step_Name);

      Wave_Opt.File.Finalize;

      if Str_Table.Last > 0 then
         Freeze_Strings;
      end if;

      -- Register_Cycle_Hook (Vcd_Cycle'Access);
      Write_Strings_Compress;
      Write_Types;
      Write_Known_Types;
      Write_Hierarchy (Root);

      Wave_Opt.Design.Last_Checks;

      --  End of header mark.
      Wave_Section ("EOH" & NUL);

      --  Write the first snapshot just before running processes for the first
      --  time.  At that point, signals are fully initialized.
      Register_Callback (Cb_Start_Of_Processes, H, Oneshot,
                         Wave_Start_Cb'Access);

      Register_Cycle_Hook (Wave_Cycle'Access);

      fflush (Wave_Stream);
   end Wave_Start;

   Wave_Time : Std_Time := 0;
   In_Cyc : Boolean := False;

   procedure Wave_Close_Cyc
   is
   begin
      Wave_Put_LSLEB128 (-1);
      Wave_Put ("ECY" & NUL);
      In_Cyc := False;
   end Wave_Close_Cyc;

   procedure Wave_Cycle
   is
      Diff : Std_Time;
      Sig : Ghdl_Signal_Ptr;
      Last : Natural;
   begin
      if not In_Cyc then
         Wave_Section ("CYC" & NUL);
         Wave_Put_I64 (Ghdl_I64 (Current_Time));
         In_Cyc := True;
      else
         Diff := Current_Time - Wave_Time;
         Wave_Put_LSLEB128 (Ghdl_I64 (Diff));
      end if;
      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.RO_Event then
            Wave_Put_ULEB128 (Ghdl_U32 (I - Last));
            Last := I;
            Write_Signal_Value (Sig);
            Sig.Flags.RO_Event := False;
         end if;
      end loop;
      Wave_Put_Byte (0);
   end Wave_Cycle;

   --  Called at the end of the simulation.
   procedure Wave_End is
   begin
      if Wave_Stream = NULL_Stream then
         return;
      end if;
      if In_Cyc then
         Wave_Close_Cyc;
      end if;
      Wave_Write_Directory;
      fclose (Wave_Stream);
   end Wave_End;

   Wave_Hooks : aliased constant Hooks_Type :=
     (Desc => new String'("ghw: save waveforms in ghw file format"),
      Option => Wave_Option'Access,
      Help => Wave_Help'Access,
      Init => Wave_Init'Access,
      Start => Wave_Start'Access,
      Finish => Wave_End'Access);

   procedure Register is
   begin
      Register_Hooks (Wave_Hooks'Access);
   end Register;
end Grt.Waves;
