diff options
Diffstat (limited to 'translate/grt/grt-disp_rti.adb')
| -rw-r--r-- | translate/grt/grt-disp_rti.adb | 1369 |
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 000000000..47e5ac6ce --- /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; |