Move files and dirs from translate/

1 files changed, 1632 insertions, 0 deletions

diff --git a/src/grt/grt-waves.adb b/src/grt/grt-waves.adb
new file mode 100644
index 000000000..63bdb9a54
--- /dev/null
+++ b/src/grt/grt-waves.adb
@@ -0,0 +1,1632 @@
+--  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 Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with Interfaces; use Interfaces;
+with System.Storage_Elements; --  Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+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.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 System; use System;
+with Grt.Vstrings; use Grt.Vstrings;
+
+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;
+
+   Ghw_Hie_Design       : constant Unsigned_8 := 1;
+   Ghw_Hie_Block        : constant Unsigned_8 := 3;
+   Ghw_Hie_Generate_If  : constant Unsigned_8 := 4;
+   Ghw_Hie_Generate_For : constant Unsigned_8 := 5;
+   Ghw_Hie_Instance     : constant Unsigned_8 := 6;
+   Ghw_Hie_Package      : constant Unsigned_8 := 7;
+   Ghw_Hie_Process      : constant Unsigned_8 := 13;
+   Ghw_Hie_Generic      : constant Unsigned_8 := 14;
+   Ghw_Hie_Eos          : constant Unsigned_8 := 15; --  End of scope.
+   Ghw_Hie_Signal       : constant Unsigned_8 := 16; --  Signal.
+   Ghw_Hie_Port_In      : constant Unsigned_8 := 17; --  Port
+   Ghw_Hie_Port_Out     : constant Unsigned_8 := 18; --  Port
+   Ghw_Hie_Port_Inout   : constant Unsigned_8 := 19; --  Port
+   Ghw_Hie_Port_Buffer  : constant Unsigned_8 := 20; --  Port
+   Ghw_Hie_Port_Linkage : constant Unsigned_8 := 21; --  Port
+
+   pragma Unreferenced (Ghw_Hie_Design);
+   pragma Unreferenced (Ghw_Hie_Generic);
+
+   --  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 : Value_Union; 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_C ("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;
+   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 : Ghdl_Rtin_Type_Enum_Acc;
+            begin
+               Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+               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 : Ghdl_Rtin_Subtype_Array_Acc;
+               B_Ctxt : Rti_Context;
+            begin
+               Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+               Create_String_Id (Arr.Name);
+               if Rti_Complex_Type (Rti) then
+                  B_Ctxt := Ctxt;
+               else
+                  B_Ctxt := N_Ctxt;
+               end if;
+               Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), B_Ctxt);
+            end;
+         when Ghdl_Rtik_Type_Array =>
+            declare
+               Arr : Ghdl_Rtin_Type_Array_Acc;
+            begin
+               Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti);
+               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 : Ghdl_Rtin_Subtype_Scalar_Acc;
+            begin
+               Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
+               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 : Ghdl_Rtin_Type_Scalar_Acc;
+            begin
+               Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
+               Create_String_Id (Base.Name);
+            end;
+         when Ghdl_Rtik_Type_P32
+           | Ghdl_Rtik_Type_P64 =>
+            declare
+               Base : Ghdl_Rtin_Type_Physical_Acc;
+               Unit_Name : Ghdl_C_String;
+            begin
+               Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+               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 =>
+            declare
+               Rec : Ghdl_Rtin_Type_Record_Acc;
+               El : Ghdl_Rtin_Element_Acc;
+            begin
+               Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti);
+               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 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 unconstrained array, also put the object
+      --  in the type AVL.
+      --  The real type will be written to the file.
+      if Rti.Kind = Ghdl_Rtik_Type_Array then
+         Add_Type (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
+      end if;
+   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);
+      if Rti.Kind = Ghdl_Rtik_Type_Array then
+         Write_Type_Id (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
+      else
+         Write_Type_Id (Rti, Avhpi_Get_Context (Obj_Type));
+      end if;
+   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).all, 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);
+
+   procedure Wave_Put_Hierarchy_1 (Inst : VhpiHandleT; Step : Step_Type)
+   is
+      Decl_It : VhpiHandleT;
+      Decl : VhpiHandleT;
+      Error : AvhpiErrorT;
+   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 =>
+               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;
+               --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;
+
+         case Vhpi_Get_Kind (Decl) is
+            when VhpiIfGenerateK
+              | VhpiForGenerateK
+              | VhpiBlockStmtK
+              | VhpiCompInstStmtK =>
+               Wave_Put_Hierarchy_Block (Decl, Step);
+            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 loop;
+   end Wave_Put_Hierarchy_1;
+
+   procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type)
+   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);
+
+      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;
+   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;
+
+         Wave_Put_Hierarchy_Block (Pack, Step);
+      end loop;
+
+      --  Then top entity.
+      Wave_Put_Hierarchy_Block (Root, Step);
+   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;
+
+   procedure Write_Range (Rti : Ghdl_Rti_Access; Rng : Ghdl_Range_Ptr)
+   is
+      Kind : Ghdl_Rtik;
+   begin
+      Kind := Rti.Kind;
+      if Kind = Ghdl_Rtik_Subtype_Scalar then
+         Kind := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype.Kind;
+      end if;
+      case Kind is
+         when Ghdl_Rtik_Type_B1 =>
+            Wave_Put_Byte (Ghdl_Rtik'Pos (Kind)
+                           + 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 (Ghdl_Rtik'Pos (Kind)
+                           + 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 (Ghdl_Rtik'Pos (Kind)
+                           + 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 (Ghdl_Rtik'Pos (Kind)
+                           + 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 (Ghdl_Rtik'Pos (Kind)
+                           + 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_Types
+   is
+      Rti : Ghdl_Rti_Access;
+      Ctxt : Rti_Context;
+   begin
+      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
+               Obj_Rti : constant Ghdl_Rtin_Object_Acc :=
+                 To_Ghdl_Rtin_Object_Acc (Rti);
+               Arr : constant Ghdl_Rtin_Type_Array_Acc :=
+                 To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type);
+               Addr : Ghdl_Uc_Array_Acc;
+            begin
+               Wave_Put_Byte (Ghdl_Rtik'Pos (Ghdl_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));
+               declare
+                  Rngs : Ghdl_Range_Array (0 .. Arr.Nbr_Dim - 1);
+               begin
+                  Bound_To_Range (Addr.Bounds, Arr, Rngs);
+                  for I in Rngs'Range loop
+                     Write_Range (Arr.Indexes (I), Rngs (I));
+                  end loop;
+               end;
+            end;
+         else
+            --  Kind.
+            Wave_Put_Byte (Ghdl_Rtik'Pos (Rti.Kind));
+            case Rti.Kind is
+               when Ghdl_Rtik_Type_B1
+                 | Ghdl_Rtik_Type_E8 =>
+                  declare
+                     Enum : Ghdl_Rtin_Type_Enum_Acc;
+                  begin
+                     Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+                     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 : Ghdl_Rtin_Subtype_Array_Acc;
+                  begin
+                     Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+                     Write_String_Id (Arr.Name);
+                     Write_Type_Id (To_Ghdl_Rti_Access (Arr.Basetype), Ctxt);
+                     declare
+                        Rngs : Ghdl_Range_Array
+                          (0 .. Arr.Basetype.Nbr_Dim - 1);
+                     begin
+                        Bound_To_Range
+                          (Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt),
+                           Arr.Basetype, Rngs);
+                        for I in Rngs'Range loop
+                           Write_Range (Arr.Basetype.Indexes (I), Rngs (I));
+                        end loop;
+                     end;
+                  end;
+               when Ghdl_Rtik_Type_Array =>
+                  declare
+                     Arr : Ghdl_Rtin_Type_Array_Acc;
+                  begin
+                     Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti);
+                     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 =>
+                  declare
+                     Rec : Ghdl_Rtin_Type_Record_Acc;
+                     El : Ghdl_Rtin_Element_Acc;
+                  begin
+                     Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti);
+                     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_Scalar =>
+                  declare
+                     Sub : Ghdl_Rtin_Subtype_Scalar_Acc;
+                  begin
+                     Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
+                     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 : Ghdl_Rtin_Type_Scalar_Acc;
+                  begin
+                     Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
+                     Write_String_Id (Base.Name);
+                  end;
+               when Ghdl_Rtik_Type_P32
+                 | Ghdl_Rtik_Type_P64 =>
+                  declare
+                     Base : Ghdl_Rtin_Type_Physical_Acc;
+                     Unit : Ghdl_Rti_Access;
+                  begin
+                     Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+                     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, 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 (Cycle_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_Cycle;
+
+   --  Called after elaboration.
+   procedure Wave_Start
+   is
+      Root : VhpiHandleT;
+   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);
+
+      Freeze_Strings;
+
+      -- Register_Cycle_Hook (Vcd_Cycle'Access);
+      Write_Strings_Compress;
+      Write_Types;
+      Write_Known_Types;
+      Write_Hierarchy (Root);
+
+      --  End of header mark.
+      Wave_Section ("EOH" & NUL);
+
+      Write_Snapshot;
+
+      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 (Cycle_Time));
+         In_Cyc := True;
+      else
+         Diff := Cycle_Time - Wave_Time;
+         Wave_Put_LSLEB128 (Ghdl_I64 (Diff));
+      end if;
+      Wave_Time := Cycle_Time;
+
+      --  Dump signals.
+      Last := 0;
+      for I in Dump_Table.First .. Dump_Table.Last loop
+         Sig := Dump_Table.Table (I);
+         if Sig.Flags.Cyc_Event then
+            Wave_Put_ULEB128 (Ghdl_U32 (I - Last));
+            Last := I;
+            Write_Signal_Value (Sig);
+            Sig.Flags.Cyc_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;
+      fflush (Wave_Stream);
+   end Wave_End;
+
+   Wave_Hooks : aliased constant Hooks_Type :=
+     (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;