First import from sources

1 files changed, 1369 insertions, 0 deletions

diff --git a/translate/grt/grt-disp_rti.adb b/translate/grt/grt-disp_rti.adb
new file mode 100644
index 0000000..47e5ac6
--- /dev/null
+++ b/translate/grt/grt-disp_rti.adb
@@ -0,0 +1,1369 @@
+--  GHDL Run Time (GRT) - RTI dumper.
+--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GCC; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+with System; use System;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Types; use Grt.Types;
+with Grt.Errors; use Grt.Errors;
+--with Grt.Typedesc; use Grt.Typedesc;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Options; use Grt.Options;
+
+package body Grt.Disp_Rti is
+   procedure Disp_Kind (Kind : Ghdl_Rtik);
+
+   procedure Disp_Name (Name : Ghdl_C_String) is
+   begin
+      if Name = null then
+         Put (stdout, "<anonymous>");
+      else
+         Put (stdout, Name);
+      end if;
+   end Disp_Name;
+
+   --  Disp value stored at ADDR and whose type is described by RTI.
+   procedure Disp_Enum_Value
+     (Stream : FILEs; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type)
+   is
+      Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+   begin
+      Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+      Put (Stream, Enum_Rti.Names (Val));
+   end Disp_Enum_Value;
+
+   procedure Disp_Scalar_Value
+     (Stream : FILEs;
+      Rti : Ghdl_Rti_Access;
+      Addr : in out Address;
+      Is_Sig : Boolean)
+   is
+      procedure Update (S : Ghdl_Index_Type) is
+      begin
+         Addr := Addr + (S / Storage_Unit);
+      end Update;
+
+      Vptr : Ghdl_Value_Ptr;
+   begin
+      if Is_Sig then
+         Vptr := To_Ghdl_Value_Ptr (To_Addr_Acc (Addr).all);
+         Update (Address'Size);
+      else
+         Vptr := To_Ghdl_Value_Ptr (Addr);
+      end if;
+
+      case Rti.Kind is
+         when Ghdl_Rtik_Type_I32 =>
+            Put_I32 (Stream, Vptr.I32);
+            if not Is_Sig then
+               Update (32);
+            end if;
+         when Ghdl_Rtik_Type_E8 =>
+            Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E8));
+            if not Is_Sig then
+               Update (8);
+            end if;
+         when Ghdl_Rtik_Type_B2 =>
+            Disp_Enum_Value (Stream, Rti,
+                             Ghdl_Index_Type (Ghdl_B2'Pos (Vptr.B2)));
+            if not Is_Sig then
+               Update (8);
+            end if;
+         when Ghdl_Rtik_Type_F64 =>
+            Put_F64 (Stream, Vptr.F64);
+            if not Is_Sig then
+               Update (64);
+            end if;
+         when Ghdl_Rtik_Type_P64 =>
+            Put_I64 (Stream, Vptr.I64);
+            Put (Stream, " ");
+            Put (Stream,
+                 To_Ghdl_Rtin_Unit_Acc
+                 (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0)).Name);
+            if not Is_Sig then
+               Update (64);
+            end if;
+         when others =>
+            Internal_Error ("disp_rti.disp_scalar_value");
+      end case;
+   end Disp_Scalar_Value;
+
+--    function Get_Scalar_Type_Kind (Rti : Ghdl_Rti_Access) return Ghdl_Rtik
+--    is
+--       Ndef : Ghdl_Rti_Access;
+--    begin
+--       if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then
+--          Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype;
+--       else
+--          Ndef := Rti;
+--       end if;
+--       case Ndef.Kind is
+--          when Ghdl_Rtik_Type_I32 =>
+--             return Ndef.Kind;
+--          when others =>
+--             return Ghdl_Rtik_Error;
+--       end case;
+--    end Get_Scalar_Type_Kind;
+
+   procedure Disp_Value (Stream : FILEs;
+                         Rti : Ghdl_Rti_Access;
+                         Ctxt : Rti_Context;
+                         Obj : in out Address;
+                         Is_Sig : Boolean);
+
+   procedure Disp_Array_Value_1 (Stream : FILEs;
+                                 El_Rti : Ghdl_Rti_Access;
+                                 Ctxt : Rti_Context;
+                                 Rngs : Ghdl_Range_Array;
+                                 Rtis : Ghdl_Rti_Arr_Acc;
+                                 Index : Ghdl_Index_Type;
+                                 Obj : in out Address;
+                                 Is_Sig : Boolean)
+   is
+      Length : Ghdl_Index_Type;
+   begin
+      Length := Range_To_Length (Rngs (Index), Get_Base_Type (Rtis (Index)));
+      Put (Stream, "(");
+      for I in 1 .. Length loop
+         if I /= 1 then
+            Put (Stream, ", ");
+         end if;
+         if Index = Rngs'Last then
+            Disp_Value (Stream, El_Rti, Ctxt, Obj, Is_Sig);
+         else
+            Disp_Array_Value_1
+              (Stream, El_Rti, Ctxt, Rngs, Rtis, Index + 1, Obj, Is_Sig);
+         end if;
+      end loop;
+      Put (Stream, ")");
+   end Disp_Array_Value_1;
+
+   procedure Disp_Array_Value (Stream : FILEs;
+                               Rti : Ghdl_Rtin_Type_Array_Acc;
+                               Ctxt : Rti_Context;
+                               Vals : Ghdl_Uc_Array_Acc;
+                               Is_Sig : Boolean)
+   is
+      Nbr_Dim : Ghdl_Index_Type := Rti.Nbr_Dim;
+      Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1);
+      Obj : Address;
+   begin
+      Bound_To_Range (Vals.Bounds, Rti, Rngs);
+      Obj := Vals.Base;
+      Disp_Array_Value_1
+        (Stream, Rti.Element, Ctxt, Rngs, Rti.Indexes, 0, Obj, Is_Sig);
+   end Disp_Array_Value;
+
+   procedure Disp_Record_Value (Stream : FILEs;
+                                Rti : Ghdl_Rtin_Type_Record_Acc;
+                                Ctxt : Rti_Context;
+                                Obj : in out Address;
+                                Is_Sig : Boolean)
+   is
+      El : Ghdl_Rtin_Element_Acc;
+      El_Addr : Address;
+   begin
+      Put (Stream, "(");
+      for I in 1 .. Rti.Nbrel loop
+         El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1));
+         if I /= 1 then
+            Put (", ");
+         end if;
+         Put (Stream, El.Name);
+         Put (" => ");
+         if Is_Sig then
+            El_Addr := Obj + El.Sig_Off;
+         else
+            El_Addr := Obj + El.Val_Off;
+         end if;
+         Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Is_Sig);
+      end loop;
+      Put (")");
+      --  FIXME: update ADDR.
+   end Disp_Record_Value;
+
+   procedure Disp_Value
+     (Stream : FILEs;
+      Rti : Ghdl_Rti_Access;
+      Ctxt : Rti_Context;
+      Obj : in out Address;
+      Is_Sig : Boolean)
+   is
+   begin
+      case Rti.Kind is
+         when Ghdl_Rtik_Subtype_Scalar =>
+            Disp_Scalar_Value
+              (Stream, To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype,
+               Obj, Is_Sig);
+         when Ghdl_Rtik_Type_I32
+           | Ghdl_Rtik_Type_E8
+           | Ghdl_Rtik_Type_B2 =>
+            Disp_Scalar_Value (Stream, Rti, Obj, Is_Sig);
+         when Ghdl_Rtik_Type_Array =>
+            Disp_Array_Value (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt,
+                              To_Ghdl_Uc_Array_Acc (Obj), Is_Sig);
+         when Ghdl_Rtik_Subtype_Array =>
+            declare
+               St : Ghdl_Rtin_Subtype_Array_Acc :=
+                 To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+               Bt : Ghdl_Rtin_Type_Array_Acc := St.Basetype;
+               Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
+               B : Address;
+            begin
+               Bound_To_Range
+                 (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs);
+               B := Obj;
+               Disp_Array_Value_1
+                 (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig);
+            end;
+         when Ghdl_Rtik_Subtype_Array_Ptr =>
+            declare
+               St : Ghdl_Rtin_Subtype_Array_Acc :=
+                 To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+               Bt : Ghdl_Rtin_Type_Array_Acc := St.Basetype;
+               Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
+               B : Address;
+            begin
+               Bound_To_Range
+                 (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs);
+               B := To_Addr_Acc (Obj).all;
+               Disp_Array_Value_1
+                 (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig);
+            end;
+         when Ghdl_Rtik_Type_File =>
+            declare
+               Vptr : Ghdl_Value_Ptr;
+            begin
+               Vptr := To_Ghdl_Value_Ptr (Obj);
+               Put (Stream, "File#");
+               Put_I32 (Stream, Vptr.I32);
+               --  FIXME: update OBJ (not very useful since never in a
+               --   composite type).
+            end;
+         when Ghdl_Rtik_Type_Record =>
+            Disp_Record_Value
+              (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Is_Sig);
+         when others =>
+            Put (Stream, "??");
+      end case;
+   end Disp_Value;
+
+   procedure Disp_Kind (Kind : Ghdl_Rtik) is
+   begin
+      case Kind is
+         when Ghdl_Rtik_Top =>
+            Put ("ghdl_rtik_top");
+         when Ghdl_Rtik_Package =>
+            Put ("ghdl_rtik_package");
+         when Ghdl_Rtik_Package_Body =>
+            Put ("ghdl_rtik_package_body");
+         when Ghdl_Rtik_Entity =>
+            Put ("ghdl_rtik_entity");
+         when Ghdl_Rtik_Architecture =>
+            Put ("ghdl_rtik_architecture");
+
+         when Ghdl_Rtik_Port =>
+            Put ("ghdl_rtik_port");
+         when Ghdl_Rtik_Generic =>
+            Put ("ghdl_rtik_generic");
+         when Ghdl_Rtik_Process =>
+            Put ("ghdl_rtik_process");
+         when Ghdl_Rtik_Component =>
+            Put ("ghdl_rtik_component");
+         when Ghdl_Rtik_Attribute =>
+            Put ("ghdl_rtik_attribute");
+
+         when Ghdl_Rtik_Attribute_Quiet =>
+            Put ("ghdl_rtik_attribute_quiet");
+         when Ghdl_Rtik_Attribute_Stable =>
+            Put ("ghdl_rtik_attribute_stable");
+         when Ghdl_Rtik_Attribute_Transaction =>
+            Put ("ghdl_rtik_attribute_transaction");
+
+         when Ghdl_Rtik_Constant =>
+            Put ("ghdl_rtik_constant");
+         when Ghdl_Rtik_Iterator =>
+            Put ("ghdl_rtik_iterator");
+         when Ghdl_Rtik_Signal =>
+            Put ("ghdl_rtik_signal");
+         when Ghdl_Rtik_Variable =>
+            Put ("ghdl_rtik_variable");
+         when Ghdl_Rtik_Guard =>
+            Put ("ghdl_rtik_guard");
+         when Ghdl_Rtik_File =>
+            Put ("ghdl_rtik_file");
+
+         when Ghdl_Rtik_Instance =>
+            Put ("ghdl_rtik_instance");
+         when Ghdl_Rtik_Block =>
+            Put ("ghdl_rtik_block");
+         when Ghdl_Rtik_If_Generate =>
+            Put ("ghdl_rtik_if_generate");
+         when Ghdl_Rtik_For_Generate =>
+            Put ("ghdl_rtik_for_generate");
+
+         when Ghdl_Rtik_Type_B2 =>
+            Put ("ghdl_rtik_type_b2");
+         when Ghdl_Rtik_Type_E8 =>
+            Put ("ghdl_rtik_type_e8");
+         when Ghdl_Rtik_Type_P64 =>
+            Put ("ghdl_rtik_type_p64");
+         when Ghdl_Rtik_Type_I32 =>
+            Put ("ghdl_rtik_type_i32");
+
+         when Ghdl_Rtik_Type_Array =>
+            Put ("ghdl_rtik_type_array");
+         when Ghdl_Rtik_Subtype_Array =>
+            Put ("ghdl_rtik_subtype_array");
+         when Ghdl_Rtik_Subtype_Array_Ptr =>
+            Put ("ghdl_rtik_subtype_array_ptr");
+         when Ghdl_Rtik_Type_Record =>
+            Put ("ghdl_rtik_type_record");
+
+         when Ghdl_Rtik_Type_Access =>
+            Put ("ghdl_rtik_type_access");
+         when Ghdl_Rtik_Type_File =>
+            Put ("ghdl_rtik_type_file");
+
+         when Ghdl_Rtik_Subtype_Scalar =>
+            Put ("ghdl_rtik_subtype_scalar");
+
+         when Ghdl_Rtik_Element =>
+            Put ("ghdl_rtik_element");
+         when Ghdl_Rtik_Unit =>
+            Put ("ghdl_rtik_unit");
+
+         when others =>
+            Put ("ghdl_rtik_#");
+            Put_I32 (stdout, Ghdl_Rtik'Pos (Kind));
+      end case;
+   end Disp_Kind;
+
+   procedure Disp_Depth (Depth : Ghdl_Rti_Depth) is
+   begin
+      Put (", D=");
+      Put_I32 (stdout, Ghdl_I32 (Depth));
+   end Disp_Depth;
+
+   procedure Disp_Indent (Indent : Natural) is
+   begin
+      for I in 1 .. Indent loop
+         Put (' ');
+      end loop;
+   end Disp_Indent;
+
+   --  Disp a subtype_indication.
+   --  OBJ may be necessary when the subtype is an unconstrained array type,
+   --  whose bounds are stored with the object.
+   procedure Disp_Subtype_Indication
+     (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address);
+
+   procedure Disp_Range
+     (Stream : FILEs; Kind : Ghdl_Rtik; Rng : Ghdl_Range_Ptr)
+   is
+   begin
+      case Kind is
+         when Ghdl_Rtik_Type_I32
+           | Ghdl_Rtik_Type_P32 =>
+            Put_I32 (Stream, Rng.I32.Left);
+            Put_Dir (Stream, Rng.I32.Dir);
+            Put_I32 (Stream, Rng.I32.Right);
+         when Ghdl_Rtik_Type_F64 =>
+            Put_F64 (Stream, Rng.F64.Left);
+            Put_Dir (Stream, Rng.F64.Dir);
+            Put_F64 (Stream, Rng.F64.Right);
+         when Ghdl_Rtik_Type_P64 =>
+            Put_I64 (Stream, Rng.P64.Left);
+            Put_Dir (Stream, Rng.P64.Dir);
+            Put_I64 (Stream, Rng.P64.Right);
+         when others =>
+            Put ("?Scal");
+      end case;
+   end Disp_Range;
+
+   procedure Disp_Scalar_Type_Name (Def : Ghdl_Rti_Access) is
+   begin
+      case Def.Kind is
+         when Ghdl_Rtik_Subtype_Scalar =>
+            declare
+               Rti : Ghdl_Rtin_Subtype_Scalar_Acc;
+            begin
+               Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def);
+               if Rti.Name /= null then
+                  Disp_Name (Rti.Name);
+               else
+                  Disp_Scalar_Type_Name (Rti.Basetype);
+               end if;
+            end;
+         when Ghdl_Rtik_Type_B2
+           | Ghdl_Rtik_Type_E8
+           | Ghdl_Rtik_Type_E32 =>
+            Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name);
+         when Ghdl_Rtik_Type_I32
+           | Ghdl_Rtik_Type_I64 =>
+            Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name);
+         when others =>
+            Put ("#disp_scalar_type_name#");
+      end case;
+   end Disp_Scalar_Type_Name;
+
+   procedure Disp_Type_Array_Name (Def : Ghdl_Rtin_Type_Array_Acc;
+                                   Bounds_Ptr : Address)
+   is
+      Bounds : Address;
+
+      procedure Align (A : Ghdl_Index_Type) is
+      begin
+         Bounds := Align (Bounds, A);
+      end Align;
+
+      procedure Update (S : Ghdl_Index_Type) is
+      begin
+         Bounds := Bounds + (S / Storage_Unit);
+      end Update;
+
+      procedure Disp_Bounds (Def : Ghdl_Rti_Access)
+      is
+         Ndef : Ghdl_Rti_Access;
+      begin
+         if Bounds = Null_Address then
+            Put ("?");
+         else
+            if Def.Kind = Ghdl_Rtik_Subtype_Scalar then
+               Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def).Basetype;
+            else
+               Ndef := Def;
+            end if;
+            case Ndef.Kind is
+               when Ghdl_Rtik_Type_I32 =>
+                  Align (Ghdl_Range_I32'Alignment);
+                  Disp_Range (stdout, Ndef.Kind, To_Ghdl_Range_Ptr (Bounds));
+                  Update (Ghdl_Range_I32'Size);
+               when others =>
+                  Disp_Kind (Ndef.Kind);
+                  --  Bounds are not known anymore.
+                  Bounds := Null_Address;
+            end case;
+         end if;
+      end Disp_Bounds;
+   begin
+      Disp_Name (Def.Name);
+      if Bounds_Ptr = Null_Address then
+         return;
+      end if;
+      Put (" (");
+      Bounds := Bounds_Ptr;
+      for I in 0 .. Def.Nbr_Dim - 1 loop
+         if I /= 0 then
+            Put (", ");
+         end if;
+         Disp_Scalar_Type_Name (Def.Indexes (I));
+         Put (" range ");
+         Disp_Bounds (Def.Indexes (I));
+      end loop;
+      Put (")");
+   end Disp_Type_Array_Name;
+
+   procedure Disp_Subtype_Scalar_Range
+     (Stream : FILEs; Def : Ghdl_Rtin_Subtype_Scalar_Acc; Ctxt : Rti_Context)
+   is
+      Range_Addr : Address;
+      Rng : Ghdl_Range_Ptr;
+   begin
+      Range_Addr := Loc_To_Addr (Def.Common.Depth,
+                                 Def.Range_Loc, Ctxt);
+      Rng := To_Ghdl_Range_Ptr (Range_Addr);
+      Disp_Range (Stream, Def.Basetype.Kind, Rng);
+   end Disp_Subtype_Scalar_Range;
+
+   procedure Disp_Subtype_Indication
+     (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address)
+   is
+   begin
+      case Def.Kind is
+         when Ghdl_Rtik_Subtype_Scalar =>
+            declare
+               Rti : Ghdl_Rtin_Subtype_Scalar_Acc;
+            begin
+               Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def);
+               if Rti.Name /= null then
+                  Disp_Name (Rti.Name);
+               else
+                  Disp_Subtype_Indication
+                    (Rti.Basetype, Null_Context, Null_Address);
+                  Put (" range ");
+                  Disp_Subtype_Scalar_Range (stdout, Rti, Ctxt);
+               end if;
+            end;
+            --Disp_Scalar_Subtype_Name (To_Ghdl_Rtin_Scalsubtype_Acc (Def),
+            --                          Base);
+         when Ghdl_Rtik_Type_B2
+           | Ghdl_Rtik_Type_E8
+           | Ghdl_Rtik_Type_E32 =>
+            Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name);
+         when Ghdl_Rtik_Type_I32
+           | Ghdl_Rtik_Type_I64 =>
+            Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name);
+         when Ghdl_Rtik_Type_File
+           | Ghdl_Rtik_Type_Access =>
+            Disp_Name (To_Ghdl_Rtin_Type_Fileacc_Acc (Def).Name);
+         when Ghdl_Rtik_Type_Record =>
+            Disp_Name (To_Ghdl_Rtin_Type_Record_Acc (Def).Name);
+         when Ghdl_Rtik_Type_Array =>
+            declare
+               Bounds : Address;
+            begin
+               if Obj = Null_Address then
+                  Bounds := Null_Address;
+               else
+                  Bounds := To_Ghdl_Uc_Array_Acc (Obj).Bounds;
+               end if;
+               Disp_Type_Array_Name (To_Ghdl_Rtin_Type_Array_Acc (Def),
+                                     Bounds);
+            end;
+         when Ghdl_Rtik_Subtype_Array
+           | Ghdl_Rtik_Subtype_Array_Ptr =>
+            declare
+               Sdef : Ghdl_Rtin_Subtype_Array_Acc;
+            begin
+               Sdef := To_Ghdl_Rtin_Subtype_Array_Acc (Def);
+               if Sdef.Name /= null then
+                  Disp_Name (Sdef.Name);
+               else
+                  Disp_Type_Array_Name
+                    (Sdef.Basetype,
+                     Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt));
+               end if;
+            end;
+         when others =>
+            Disp_Kind (Def.Kind);
+            Put (' ');
+      end case;
+   end Disp_Subtype_Indication;
+
+
+   procedure Disp_Rti (Rti : Ghdl_Rti_Access;
+                       Ctxt : Rti_Context;
+                       Indent : Natural);
+
+   procedure Disp_Rti_Arr (Nbr : Ghdl_Index_Type;
+                           Arr : Ghdl_Rti_Arr_Acc;
+                           Ctxt : Rti_Context;
+                           Indent : Natural)
+   is
+   begin
+      for I in 1 .. Nbr loop
+         Disp_Rti (Arr (I - 1), Ctxt, Indent);
+      end loop;
+   end Disp_Rti_Arr;
+
+   procedure Disp_Block (Blk : Ghdl_Rtin_Block_Acc;
+                         Ctxt : Rti_Context;
+                         Indent : Natural)
+   is
+      Nctxt : Rti_Context;
+   begin
+      Disp_Indent (Indent);
+      Disp_Kind (Blk.Common.Kind);
+      Disp_Depth (Blk.Common.Depth);
+      Put (": ");
+      Disp_Name (Blk.Name);
+      New_Line;
+      if Blk.Parent /= null then
+         case Blk.Common.Kind is
+            when Ghdl_Rtik_Architecture =>
+               --  Disp entity.
+               Disp_Rti (Blk.Parent, Ctxt, Indent + 1);
+            when others =>
+               null;
+         end case;
+      end if;
+      case Blk.Common.Kind is
+         when Ghdl_Rtik_Package
+           | Ghdl_Rtik_Package_Body
+           | Ghdl_Rtik_Entity
+           | Ghdl_Rtik_Architecture
+           | Ghdl_Rtik_Block
+           | Ghdl_Rtik_Process =>
+            Nctxt := (Base => Ctxt.Base + Blk.Loc.Off,
+                      Block => To_Ghdl_Rti_Access (Blk));
+            Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children,
+                          Nctxt, Indent + 1);
+         when Ghdl_Rtik_For_Generate =>
+            declare
+               Length : Ghdl_Index_Type;
+            begin
+               Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc.Off).all,
+                         Block => To_Ghdl_Rti_Access (Blk));
+               Length := Get_For_Generate_Length (Blk, Ctxt);
+               for I in 1 .. Length loop
+                  Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children,
+                                Nctxt, Indent + 1);
+                  Nctxt.Base := Nctxt.Base + Blk.Size;
+               end loop;
+            end;
+         when Ghdl_Rtik_If_Generate =>
+            Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc.Off).all,
+                      Block => To_Ghdl_Rti_Access (Blk));
+            if Nctxt.Base /= Null_Address then
+               Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children,
+                             Nctxt, Indent + 1);
+            end if;
+         when others =>
+            Internal_Error ("disp_block");
+      end case;
+   end Disp_Block;
+
+   procedure Disp_Object (Obj : Ghdl_Rtin_Object_Acc;
+                          Is_Sig : Boolean;
+                          Ctxt : Rti_Context;
+                          Indent : Natural)
+   is
+      Addr : Address;
+      Obj_Type : Ghdl_Rti_Access;
+   begin
+      Disp_Indent (Indent);
+      Disp_Kind (Obj.Common.Kind);
+      Disp_Depth (Obj.Common.Depth);
+      Put ("; ");
+      Disp_Name (Obj.Name);
+      Put (": ");
+      Addr := Loc_To_Addr (Obj.Common.Depth, Obj.Loc, Ctxt);
+      Obj_Type := Obj.Obj_Type;
+      Disp_Subtype_Indication (Obj_Type, Ctxt, Addr);
+      Put (" := ");
+
+      --  FIXME: put this into a function.
+      if Obj_Type.Kind = Ghdl_Rtik_Subtype_Array
+        and then Obj_Type.Mode = 1
+      then
+         Addr := To_Addr_Acc (Addr).all;
+      end if;
+      Disp_Value (stdout, Obj_Type, Ctxt, Addr, Is_Sig);
+      New_Line;
+   end Disp_Object;
+
+   procedure Disp_Attribute (Obj : Ghdl_Rtin_Object_Acc;
+                             Ctxt : Rti_Context;
+                             Indent : Natural)
+   is
+   begin
+      Disp_Indent (Indent);
+      Disp_Kind (Obj.Common.Kind);
+      Disp_Depth (Obj.Common.Depth);
+      Put ("; ");
+      Disp_Name (Obj.Name);
+      Put (": ");
+      Disp_Subtype_Indication (Obj.Obj_Type, Ctxt, Null_Address);
+      New_Line;
+   end Disp_Attribute;
+
+   procedure Disp_Component (Comp : Ghdl_Rtin_Component_Acc;
+                             Indent : Natural)
+   is
+   begin
+      Disp_Indent (Indent);
+      Disp_Kind (Comp.Common.Kind);
+      Disp_Depth (Comp.Common.Depth);
+      Put (": ");
+      Disp_Name (Comp.Name);
+      New_Line;
+      --Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Base, Ident + 1);
+   end Disp_Component;
+
+   procedure Disp_Instance (Inst : Ghdl_Rtin_Instance_Acc;
+                            Ctxt : Rti_Context;
+                            Indent : Natural)
+   is
+      Inst_Addr : Address;
+      Inst_Base : Address;
+      Inst_Rti : Ghdl_Rti_Access;
+      Nindent : Natural;
+      Nctxt : Rti_Context;
+   begin
+      Disp_Indent (Indent);
+      Disp_Kind (Inst.Common.Kind);
+      Put (": ");
+      Disp_Name (Inst.Name);
+      New_Line;
+
+      Inst_Addr := Ctxt.Base + Inst.Loc.Off;
+      --  Read sub instance.
+      Inst_Base := To_Addr_Acc (Inst_Addr).all;
+
+      Nindent := Indent + 1;
+
+      case Inst.Instance.Kind is
+         when Ghdl_Rtik_Component =>
+            declare
+               Comp : Ghdl_Rtin_Component_Acc;
+            begin
+               Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance);
+               Disp_Indent (Nindent);
+               Disp_Kind (Comp.Common.Kind);
+               Put (": ");
+               Disp_Name (Comp.Name);
+               New_Line;
+               --  Disp components generics and ports.
+               --  FIXME: the data to disp are at COMP_BASE.
+               Nctxt := (Base => Inst_Addr,
+                         Block => Inst.Instance);
+               Nindent := Nindent + 1;
+               Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Nctxt, Nindent);
+               Nindent := Nindent + 1;
+            end;
+         when Ghdl_Rtik_Entity =>
+            null;
+         when others =>
+            null;
+      end case;
+
+      --  Read instance RTI.
+      if Inst_Base /= Null_Address then
+         Inst_Rti := To_Ghdl_Rti_Acc_Acc (Inst_Base).all;
+         Nctxt := (Base => Inst_Base,
+                   Block => Inst_Rti);
+         Disp_Block (To_Ghdl_Rtin_Block_Acc (Inst_Rti),
+                     Nctxt, Nindent);
+      end if;
+   end Disp_Instance;
+
+   procedure Disp_Type_Enum_Decl (Enum : Ghdl_Rtin_Type_Enum_Acc;
+                                  Indent : Natural)
+   is
+   begin
+      Disp_Indent (Indent);
+      Disp_Kind (Enum.Common.Kind);
+      Put (": ");
+      Disp_Name (Enum.Name);
+      Put (" is (");
+      Disp_Name (Enum.Names (0));
+      for I in 1 .. Enum.Nbr - 1 loop
+         Put (", ");
+         Disp_Name (Enum.Names (I));
+      end loop;
+      Put (")");
+      New_Line;
+   end Disp_Type_Enum_Decl;
+
+   procedure Disp_Subtype_Scalar_Decl (Def : Ghdl_Rtin_Subtype_Scalar_Acc;
+                                       Ctxt : Rti_Context;
+                                       Indent : Natural)
+   is
+      Bt : Ghdl_Rti_Access;
+   begin
+      Disp_Indent (Indent);
+      Disp_Kind (Def.Common.Kind);
+      Disp_Depth (Def.Common.Depth);
+      Put (": ");
+      Disp_Name (Def.Name);
+      Put (" is ");
+      Bt := Def.Basetype;
+      case Bt.Kind is
+         when Ghdl_Rtik_Type_I32
+           | Ghdl_Rtik_Type_F64 =>
+            declare
+               Bdef : Ghdl_Rtin_Type_Scalar_Acc;
+            begin
+               Bdef := To_Ghdl_Rtin_Type_Scalar_Acc (Bt);
+               if Bdef.Name /= Def.Name then
+                  Disp_Name (Bdef.Name);
+                  Put (" range ");
+               end if;
+               --  This is the type definition.
+               Disp_Subtype_Scalar_Range (stdout, Def, Ctxt);
+            end;
+         when Ghdl_Rtik_Type_P64
+           | Ghdl_Rtik_Type_P32 =>
+            declare
+               Bdef : Ghdl_Rtin_Type_Physical_Acc;
+               Unit : Ghdl_Rtin_Unit_Acc;
+            begin
+               Bdef := To_Ghdl_Rtin_Type_Physical_Acc (Bt);
+               if Bdef.Name /= Def.Name then
+                  Disp_Name (Bdef.Name);
+                  Put (" range ");
+               end if;
+               --  This is the type definition.
+               Disp_Subtype_Scalar_Range (stdout, Def, Ctxt);
+               if Bdef.Name = Def.Name then
+                  for I in 0 .. Bdef.Nbr - 1 loop
+                     Unit := To_Ghdl_Rtin_Unit_Acc (Bdef.Units (I));
+                     New_Line;
+                     Disp_Indent (Indent + 1);
+                     Disp_Kind (Unit.Common.Kind);
+                     Put (": ");
+                     Disp_Name (Unit.Name);
+                     Put (" = ");
+                     case Bt.Kind is
+                        when Ghdl_Rtik_Type_P64 =>
+                           if Bt.Mode = 0 then
+                              Put_I64 (stdout, Unit.Value.Unit_64);
+                           else
+                              Put_I64 (stdout, Unit.Value.Unit_Addr.I64);
+                           end if;
+                        when Ghdl_Rtik_Type_P32 =>
+                           if Bt.Mode = 0 then
+                              Put_I32 (stdout, Unit.Value.Unit_32);
+                           else
+                              Put_I32 (stdout, Unit.Value.Unit_Addr.I32);
+                           end if;
+                        when others =>
+                           null;
+                     end case;
+                  end loop;
+               end if;
+            end;
+         when others =>
+            Disp_Subtype_Indication
+              (To_Ghdl_Rti_Access (Def), Ctxt, Null_Address);
+      end case;
+      New_Line;
+   end Disp_Subtype_Scalar_Decl;
+
+   procedure Disp_Type_Array_Decl (Def : Ghdl_Rtin_Type_Array_Acc;
+                                   Ctxt : Rti_Context;
+                                   Indent : Natural)
+   is
+   begin
+      Disp_Indent (Indent);
+      Disp_Kind (Def.Common.Kind);
+      Put (": ");
+      Disp_Name (Def.Name);
+      Put (" is array (");
+      for I in 0 .. Def.Nbr_Dim - 1 loop
+         if I /= 0 then
+            Put (", ");
+         end if;
+         Disp_Subtype_Indication (Def.Indexes (I), Ctxt, Null_Address);
+         Put (" range <>");
+      end loop;
+      Put (") of ");
+      Disp_Subtype_Indication (Def.Element, Ctxt, Null_Address);
+      New_Line;
+   end Disp_Type_Array_Decl;
+
+   procedure Disp_Subtype_Array_Decl (Def : Ghdl_Rtin_Subtype_Array_Acc;
+                                      Ctxt : Rti_Context;
+                                      Indent : Natural)
+   is
+   begin
+      Disp_Indent (Indent);
+      Disp_Kind (Def.Common.Kind);
+      Put (": ");
+      Disp_Name (Def.Name);
+      Put (" is ");
+      Disp_Type_Array_Name
+        (Def.Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt));
+      --  FIXME: If the subtype array contains a type array, then the
+      --  definition is not complete: display the element type.
+      New_Line;
+   end Disp_Subtype_Array_Decl;
+
+   procedure Disp_Type_File_Or_Access (Def : Ghdl_Rtin_Type_Fileacc_Acc;
+                                       Ctxt : Rti_Context;
+                                       Indent : Natural)
+   is
+   begin
+      Disp_Indent (Indent);
+      Disp_Kind (Def.Common.Kind);
+      Put (": ");
+      Disp_Name (Def.Name);
+      Put (" is ");
+      case Def.Common.Kind is
+         when Ghdl_Rtik_Type_Access =>
+            Put ("access ");
+         when Ghdl_Rtik_Type_File =>
+            Put ("file ");
+         when others =>
+            Put ("?? ");
+      end case;
+      Disp_Subtype_Indication (Def.Base, Ctxt, Null_Address);
+      New_Line;
+   end Disp_Type_File_Or_Access;
+
+   procedure Disp_Type_Record (Def : Ghdl_Rtin_Type_Record_Acc;
+                               Ctxt : Rti_Context;
+                               Indent : Natural)
+   is
+      El : Ghdl_Rtin_Element_Acc;
+   begin
+      Disp_Indent (Indent);
+      Disp_Kind (Def.Common.Kind);
+      Put (": ");
+      Disp_Name (Def.Name);
+      Put (" is record");
+      New_Line;
+      for I in 1 .. Def.Nbrel loop
+         El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1));
+         Disp_Indent (Indent + 1);
+         Disp_Kind (El.Common.Kind);
+         Put (": ");
+         Disp_Name (El.Name);
+         Put (": ");
+         Disp_Subtype_Indication (El.Eltype, Ctxt, Null_Address);
+         New_Line;
+      end loop;
+   end Disp_Type_Record;
+
+   procedure Disp_Rti (Rti : Ghdl_Rti_Access;
+                       Ctxt : Rti_Context;
+                       Indent : Natural)
+   is
+   begin
+      if Rti = null then
+         return;
+      end if;
+
+      case Rti.Kind is
+         when Ghdl_Rtik_Entity
+           | Ghdl_Rtik_Architecture
+           | Ghdl_Rtik_Package
+           | Ghdl_Rtik_Process
+           | Ghdl_Rtik_Block
+           | Ghdl_Rtik_If_Generate
+           | Ghdl_Rtik_For_Generate =>
+            Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent);
+         when Ghdl_Rtik_Package_Body =>
+            Disp_Rti (To_Ghdl_Rtin_Block_Acc (Rti).Parent, Ctxt, Indent);
+            Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent);
+         when Ghdl_Rtik_Port
+           | Ghdl_Rtik_Signal
+           | Ghdl_Rtik_Guard
+           | Ghdl_Rtik_Attribute_Quiet
+           | Ghdl_Rtik_Attribute_Stable
+           | Ghdl_Rtik_Attribute_Transaction =>
+            Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), True, Ctxt, Indent);
+         when Ghdl_Rtik_Generic
+           | Ghdl_Rtik_Constant
+           | Ghdl_Rtik_Variable
+           | Ghdl_Rtik_Iterator
+           | Ghdl_Rtik_File =>
+            Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), False, Ctxt, Indent);
+         when Ghdl_Rtik_Component =>
+            Disp_Component (To_Ghdl_Rtin_Component_Acc (Rti), Indent);
+         when Ghdl_Rtik_Attribute =>
+            Disp_Attribute (To_Ghdl_Rtin_Object_Acc (Rti), Ctxt, Indent);
+         when Ghdl_Rtik_Instance =>
+            Disp_Instance (To_Ghdl_Rtin_Instance_Acc (Rti), Ctxt, Indent);
+         when Ghdl_Rtik_Type_B2
+           | Ghdl_Rtik_Type_E8
+           | Ghdl_Rtik_Type_E32 =>
+            Disp_Type_Enum_Decl (To_Ghdl_Rtin_Type_Enum_Acc (Rti), Indent);
+         when Ghdl_Rtik_Subtype_Scalar =>
+            Disp_Subtype_Scalar_Decl (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti),
+                                      Ctxt, Indent);
+         when Ghdl_Rtik_Type_Array =>
+            Disp_Type_Array_Decl
+              (To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, Indent);
+         when Ghdl_Rtik_Subtype_Array
+           | Ghdl_Rtik_Subtype_Array_Ptr =>
+            Disp_Subtype_Array_Decl
+              (To_Ghdl_Rtin_Subtype_Array_Acc (Rti), Ctxt, Indent);
+         when Ghdl_Rtik_Type_Access
+           | Ghdl_Rtik_Type_File =>
+            Disp_Type_File_Or_Access
+              (To_Ghdl_Rtin_Type_Fileacc_Acc (Rti), Ctxt, Indent);
+         when Ghdl_Rtik_Type_Record =>
+            Disp_Type_Record
+              (To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Indent);
+         when others =>
+            Disp_Indent (Indent);
+            Disp_Kind (Rti.Kind);
+            Put_Line (" ? ");
+      end case;
+   end Disp_Rti;
+
+   procedure Disp_All
+   is
+      Ctxt : Rti_Context;
+   begin
+      Put ("DISP_RTI.Disp_All: ");
+      Disp_Kind (Ghdl_Rti_Top_Ptr.Common.Kind);
+      New_Line;
+      Ctxt := (Base => To_Address (Ghdl_Rti_Top_Instance),
+               Block => Ghdl_Rti_Top_Ptr.Parent);
+      Disp_Rti_Arr (Ghdl_Rti_Top_Ptr.Nbr_Child,
+                    Ghdl_Rti_Top_Ptr.Children,
+                    Ctxt, 0);
+      Disp_Rti (Ghdl_Rti_Top_Ptr.Parent, Ctxt, 0);
+
+      --Disp_Hierarchy;
+   end Disp_All;
+
+   --  Get next interesting child.
+   procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc;
+                             Index : in out Ghdl_Index_Type;
+                             Child : out Ghdl_Rti_Access)
+   is
+   begin
+      --  Exit if no more children.
+      while Index < Parent.Nbr_Child loop
+         Child := Parent.Children (Index);
+         Index := Index + 1;
+         case Child.Kind is
+            when Ghdl_Rtik_Package
+              | Ghdl_Rtik_Entity
+              | Ghdl_Rtik_Architecture
+              | Ghdl_Rtik_Block
+              | Ghdl_Rtik_For_Generate
+              | Ghdl_Rtik_If_Generate
+              | Ghdl_Rtik_Instance =>
+               return;
+            when Ghdl_Rtik_Signal
+              | Ghdl_Rtik_Port
+              | Ghdl_Rtik_Guard =>
+               if Disp_Tree >= Disp_Tree_Port then
+                  return;
+               end if;
+            when Ghdl_Rtik_Process =>
+               if Disp_Tree >= Disp_Tree_Proc then
+                  return;
+               end if;
+            when others =>
+               null;
+         end case;
+      end loop;
+      Child := null;
+   end Get_Tree_Child;
+
+   procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
+   is
+   begin
+      case Rti.Kind is
+         when Ghdl_Rtik_Entity
+           | Ghdl_Rtik_Process
+           | Ghdl_Rtik_Architecture
+           | Ghdl_Rtik_Block
+           | Ghdl_Rtik_If_Generate =>
+            declare
+               Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti);
+            begin
+               Disp_Name (Blk.Name);
+            end;
+         when Ghdl_Rtik_Package_Body
+           | Ghdl_Rtik_Package =>
+            declare
+               Blk : Ghdl_Rtin_Block_Acc;
+               Lib : Ghdl_Rtin_Type_Scalar_Acc;
+            begin
+               Blk := To_Ghdl_Rtin_Block_Acc (Rti);
+               if Rti.Kind = Ghdl_Rtik_Package_Body then
+                  Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+               end if;
+               Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent);
+               Disp_Name (Lib.Name);
+               Put ('.');
+               Disp_Name (Blk.Name);
+            end;
+         when Ghdl_Rtik_For_Generate =>
+            declare
+               Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti);
+               Iter : Ghdl_Rtin_Object_Acc;
+               Addr : Address;
+            begin
+               Disp_Name (Blk.Name);
+               Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
+               Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
+               Put ('(');
+               Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False);
+               Put (')');
+            end;
+         when Ghdl_Rtik_Signal
+           | Ghdl_Rtik_Port
+           | Ghdl_Rtik_Guard
+           | Ghdl_Rtik_Iterator =>
+            Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name);
+         when Ghdl_Rtik_Instance =>
+            Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name);
+         when others =>
+            null;
+      end case;
+
+      case Rti.Kind is
+         when Ghdl_Rtik_Package
+           | Ghdl_Rtik_Package_Body =>
+            Put (" [package]");
+         when Ghdl_Rtik_Entity =>
+            Put (" [entity]");
+         when Ghdl_Rtik_Architecture =>
+            Put (" [arch]");
+         when Ghdl_Rtik_Process =>
+            Put (" [process]");
+         when Ghdl_Rtik_Block =>
+            Put (" [block]");
+         when Ghdl_Rtik_For_Generate =>
+            Put (" [for-generate]");
+         when Ghdl_Rtik_If_Generate =>
+            Put (" [if-generate ");
+            if Ctxt.Base = Null_Address then
+               Put ("false]");
+            else
+               Put ("true]");
+            end if;
+         when Ghdl_Rtik_Signal =>
+            Put (" [signal]");
+         when Ghdl_Rtik_Port =>
+            Put (" [port ");
+            case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is
+               when Ghdl_Rti_Signal_Mode_In =>
+                  Put ("in");
+               when Ghdl_Rti_Signal_Mode_Out =>
+                  Put ("out");
+               when Ghdl_Rti_Signal_Mode_Inout =>
+                  Put ("inout");
+               when Ghdl_Rti_Signal_Mode_Buffer =>
+                  Put ("buffer");
+               when Ghdl_Rti_Signal_Mode_Linkage =>
+                  Put ("linkage");
+               when others =>
+                  Put ("?");
+            end case;
+            Put ("]");
+         when Ghdl_Rtik_Guard =>
+            Put (" [guard]");
+         when Ghdl_Rtik_Iterator =>
+            Put (" [iterator]");
+         when Ghdl_Rtik_Instance =>
+            Put (" [instance]");
+         when others =>
+            null;
+      end case;
+   end Disp_Tree_Child;
+
+   procedure Disp_Tree_Block
+     (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String);
+
+   procedure Disp_Tree_Block1
+     (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
+   is
+      Child : Ghdl_Rti_Access;
+      Child2 : Ghdl_Rti_Access;
+      Index : Ghdl_Index_Type;
+
+      procedure Disp_Header (Nctxt : Rti_Context;
+                             Force_Cont : Boolean := False)
+      is
+      begin
+         Put (Pfx);
+
+         if Blk.Common.Kind /= Ghdl_Rtik_Entity
+           and Child2 = null
+           and Force_Cont = False
+         then
+            Put ("`-");
+         else
+            Put ("+-");
+         end if;
+
+         Disp_Tree_Child (Child, Nctxt);
+         New_Line;
+      end Disp_Header;
+
+      procedure Disp_Sub_Block
+        (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context)
+      is
+         Npfx : String (1 .. Pfx'Length + 2);
+      begin
+         Npfx (1 .. Pfx'Length) := Pfx;
+         Npfx (Pfx'Length + 2) := ' ';
+         if Child2 = null then
+            Npfx (Pfx'Length + 1) := ' ';
+         else
+            Npfx (Pfx'Length + 1) := '|';
+         end if;
+         Disp_Tree_Block (Sub_Blk, Nctxt, Npfx);
+      end Disp_Sub_Block;
+
+   begin
+      Index := 0;
+      Get_Tree_Child (Blk, Index, Child);
+      while Child /= null loop
+         Get_Tree_Child (Blk, Index, Child2);
+
+         case Child.Kind is
+            when Ghdl_Rtik_Process
+              | Ghdl_Rtik_Block =>
+               declare
+                  Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child);
+                  Nctxt : Rti_Context;
+               begin
+                  Nctxt := (Base => Ctxt.Base + Nblk.Loc.Off,
+                            Block => Child);
+                  Disp_Header (Nctxt, False);
+                  Disp_Sub_Block (Nblk, Nctxt);
+               end;
+            when Ghdl_Rtik_For_Generate =>
+               declare
+                  Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child);
+                  Nctxt : Rti_Context;
+                  Length : Ghdl_Index_Type;
+                  Old_Child2 : Ghdl_Rti_Access;
+               begin
+                  Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all,
+                            Block => Child);
+                  Length := Get_For_Generate_Length (Nblk, Ctxt);
+                  Disp_Header (Nctxt, Length > 1);
+                  Old_Child2 := Child2;
+                  if Length > 1 then
+                     Child2 := Child;
+                  end if;
+                  for I in 1 .. Length loop
+                     Disp_Sub_Block (Nblk, Nctxt);
+                     if I /= Length then
+                        Nctxt.Base := Nctxt.Base + Nblk.Size;
+                        if I = Length - 1 then
+                           Child2 := Old_Child2;
+                        end if;
+                        Disp_Header (Nctxt);
+                     end if;
+                  end loop;
+                  Child2 := Old_Child2;
+               end;
+            when Ghdl_Rtik_If_Generate =>
+               declare
+                  Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child);
+                  Nctxt : Rti_Context;
+               begin
+                  Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all,
+                            Block => Child);
+                  Disp_Header (Nctxt);
+                  if Nctxt.Base /= Null_Address then
+                     Disp_Sub_Block (Nblk, Nctxt);
+                  end if;
+               end;
+            when Ghdl_Rtik_Instance =>
+               declare
+                  Inst : Ghdl_Rtin_Instance_Acc;
+                  Sub_Ctxt : Rti_Context;
+                  Sub_Blk : Ghdl_Rtin_Block_Acc;
+                  Npfx : String (1 .. Pfx'Length + 4);
+                  Comp : Ghdl_Rtin_Component_Acc;
+                  Ch : Ghdl_Rti_Access;
+               begin
+                  Disp_Header (Ctxt);
+                  Inst := To_Ghdl_Rtin_Instance_Acc (Child);
+                  Get_Instance_Context (Inst, Ctxt, Sub_Ctxt);
+                  Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block);
+                  if Inst.Instance.Kind = Ghdl_Rtik_Component
+                    and then Disp_Tree >= Disp_Tree_Port
+                  then
+                     --  Disp generics and ports of the component.
+                     Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance);
+                     for I in 1 .. Comp.Nbr_Child loop
+                        Ch := Comp.Children (I - 1);
+                        if Ch.Kind = Ghdl_Rtik_Port then
+                           --  Disp only port (and not generics).
+                           Put (Pfx);
+                           if Child2 = null then
+                              Put ("  ");
+                           else
+                              Put ("| ");
+                           end if;
+                           if I = Comp.Nbr_Child and then Sub_Blk = null then
+                              Put ("`-");
+                           else
+                              Put ("+-");
+                           end if;
+                           Disp_Tree_Child (Ch, Sub_Ctxt);
+                           New_Line;
+                        end if;
+                     end loop;
+                  end if;
+                  if Sub_Blk /= null then
+                     Npfx (1 .. Pfx'Length) := Pfx;
+                     if Child2 = null then
+                        Npfx (Pfx'Length + 1) := ' ';
+                     else
+                        Npfx (Pfx'Length + 1) := '|';
+                     end if;
+                     Npfx (Pfx'Length + 2) := ' ';
+                     Npfx (Pfx'Length + 3) := '`';
+                     Npfx (Pfx'Length + 4) := '-';
+                     Put (Npfx);
+                     Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt);
+                     New_Line;
+                     Npfx (Pfx'Length + 3) := ' ';
+                     Npfx (Pfx'Length + 4) := ' ';
+                     Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx);
+                  end if;
+               end;
+            when others =>
+               Disp_Header (Ctxt);
+         end case;
+
+         Child := Child2;
+      end loop;
+   end Disp_Tree_Block1;
+
+   procedure Disp_Tree_Block
+     (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
+   is
+   begin
+      case Blk.Common.Kind is
+         when Ghdl_Rtik_Architecture =>
+            declare
+               Npfx : String (1 .. Pfx'Length + 2);
+               Nctxt : Rti_Context;
+            begin
+               --  The entity.
+               Nctxt := (Base => Ctxt.Base,
+                         Block => Blk.Parent);
+               Disp_Tree_Block1
+                 (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx);
+               --  Then the architecture.
+               Put (Pfx);
+               Put ("`-");
+               Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt);
+               New_Line;
+               Npfx (1 .. Pfx'Length) := Pfx;
+               Npfx (Pfx'Length + 1) := ' ';
+               Npfx (Pfx'Length + 2) := ' ';
+               Disp_Tree_Block1 (Blk, Ctxt, Npfx);
+            end;
+         when Ghdl_Rtik_Package_Body =>
+            Disp_Tree_Block1
+              (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx);
+         when others =>
+            Disp_Tree_Block1 (Blk, Ctxt, Pfx);
+      end case;
+   end Disp_Tree_Block;
+
+   procedure Disp_Hierarchy
+   is
+      Ctxt : Rti_Context;
+      Parent : Ghdl_Rtin_Block_Acc;
+      Child : Ghdl_Rti_Access;
+   begin
+      Ctxt := Get_Top_Context;
+      Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+
+      Disp_Tree_Child (Parent.Parent, Ctxt);
+      New_Line;
+      Disp_Tree_Block (Parent, Ctxt, "");
+
+      for I in 1 .. Ghdl_Rti_Top_Ptr.Nbr_Child loop
+         Child := Ghdl_Rti_Top_Ptr.Children (I - 1);
+         Ctxt := (Base => Null_Address,
+                  Block => Child);
+         Disp_Tree_Child (Child, Ctxt);
+         New_Line;
+         Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, "");
+      end loop;
+   end Disp_Hierarchy;
+end Grt.Disp_Rti;