aboutsummaryrefslogtreecommitdiffstats
path: root/src/grt/grt-disp_rti.adb
diff options
context:
space:
mode:
authorTristan Gingold <tgingold@free.fr>2014-11-05 05:11:00 +0100
committerTristan Gingold <tgingold@free.fr>2014-11-05 05:11:00 +0100
commit3fddf1c59fd7a8fcd260bb9e05c611bef3dd141b (patch)
treecbfe6d75f8e09db8b98f335406fb6ecb2fce3e0c /src/grt/grt-disp_rti.adb
parent0a088b311ed2fcebc542f8a2e42d09e2e3c9311c (diff)
downloadghdl-3fddf1c59fd7a8fcd260bb9e05c611bef3dd141b.tar.gz
ghdl-3fddf1c59fd7a8fcd260bb9e05c611bef3dd141b.tar.bz2
ghdl-3fddf1c59fd7a8fcd260bb9e05c611bef3dd141b.zip
Move files and dirs from translate/
Diffstat (limited to 'src/grt/grt-disp_rti.adb')
-rw-r--r--src/grt/grt-disp_rti.adb1080
1 files changed, 1080 insertions, 0 deletions
diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb
new file mode 100644
index 000000000..08d27dacb
--- /dev/null
+++ b/src/grt/grt-disp_rti.adb
@@ -0,0 +1,1080 @@
+-- GHDL Run Time (GRT) - RTI dumper.
+-- 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 Grt.Astdio; use Grt.Astdio;
+with Grt.Errors; use Grt.Errors;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+
+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_E32 =>
+ Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E32));
+ if not Is_Sig then
+ Update (32);
+ end if;
+ when Ghdl_Rtik_Type_B1 =>
+ Disp_Enum_Value (Stream, Rti,
+ Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1)));
+ 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,
+ Get_Physical_Unit_Name
+ (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0)));
+ if not Is_Sig then
+ Update (64);
+ end if;
+ when Ghdl_Rtik_Type_P32 =>
+ Put_I32 (Stream, Vptr.I32);
+ Put (Stream, " ");
+ Put (Stream,
+ Get_Physical_Unit_Name
+ (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0)));
+ if not Is_Sig then
+ Update (32);
+ 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_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 : constant 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 : 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;
+ if Rti_Complex_Type (El.Eltype) then
+ El_Addr := Obj + To_Ghdl_Index_Acc (El_Addr).all;
+ 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_E32
+ | Ghdl_Rtik_Type_B1 =>
+ 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 : constant Ghdl_Rtin_Subtype_Array_Acc :=
+ To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Bt : constant 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_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 Ghdl_Rtik_Type_Protected =>
+ Put (Stream, "Unhandled protected type");
+ when others =>
+ Put (Stream, "Unknown Rti Kind : ");
+ Disp_Kind(Rti.Kind);
+ end case;
+ -- Put_Line(":");
+ 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_B1 =>
+ Put ("ghdl_rtik_type_b1");
+ when Ghdl_Rtik_Type_E8 =>
+ Put ("ghdl_rtik_type_e8");
+ when Ghdl_Rtik_Type_E32 =>
+ Put ("ghdl_rtik_type_e32");
+ 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_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_Type_Protected =>
+ Put ("ghdl_rtik_type_protected");
+
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Put ("ghdl_rtik_subtype_scalar");
+
+ when Ghdl_Rtik_Element =>
+ Put ("ghdl_rtik_element");
+ when Ghdl_Rtik_Unit64 =>
+ Put ("ghdl_rtik_unit64");
+ when Ghdl_Rtik_Unitptr =>
+ Put ("ghdl_rtik_unitptr");
+
+ 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_B1
+ | 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, Ghdl_Rti_Loc (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_B1
+ | 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 =>
+ 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 Ghdl_Rtik_Type_Protected =>
+ Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name);
+ 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,
+ 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).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).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
+ or Obj_Type.Kind = Ghdl_Rtik_Type_Record)
+ and then Rti_Complex_Type (Obj_Type)
+ 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;
+ -- 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_Rti_Access;
+ 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 := Bdef.Units (I);
+ New_Line;
+ Disp_Indent (Indent + 1);
+ Disp_Kind (Unit.Kind);
+ Put (": ");
+ Disp_Name (Get_Physical_Unit_Name (Unit));
+ Put (" = ");
+ case Unit.Kind is
+ when Ghdl_Rtik_Unit64 =>
+ Put_I64 (stdout,
+ To_Ghdl_Rtin_Unit64_Acc (Unit).Value);
+ when Ghdl_Rtik_Unitptr =>
+ case Bt.Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ Put_I64
+ (stdout,
+ To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64);
+ when Ghdl_Rtik_Type_P32 =>
+ Put_I32
+ (stdout,
+ To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32);
+ when others =>
+ Internal_Error
+ ("disp_rti.subtype.scalar_decl(P32/P64)");
+ end case;
+ when others =>
+ Internal_Error
+ ("disp_rti.subtype.scalar_decl(P32/P64)");
+ 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
+ Basetype : constant Ghdl_Rtin_Type_Array_Acc := Def.Basetype;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is ");
+ Disp_Type_Array_Name
+ (Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt));
+ if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then
+ Put (" of ");
+ Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address);
+ end if;
+ 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_Type_Protected (Def : Ghdl_Rtin_Type_Scalar_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ pragma Unreferenced (Ctxt);
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is protected");
+ New_Line;
+ end Disp_Type_Protected;
+
+ 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_B1
+ | 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 =>
+ 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 Ghdl_Rtik_Type_Protected =>
+ Disp_Type_Protected
+ (To_Ghdl_Rtin_Type_Scalar_Acc (Rti), Ctxt, Indent);
+ when others =>
+ Disp_Indent (Indent);
+ Disp_Kind (Rti.Kind);
+ Put_Line (" ? ");
+ end case;
+ end Disp_Rti;
+
+ Disp_Rti_Flag : Boolean := False;
+
+ procedure Disp_All
+ is
+ Ctxt : Rti_Context;
+ begin
+ if not Disp_Rti_Flag then
+ return;
+ end if;
+
+ Put ("DISP_RTI.Disp_All: ");
+ Disp_Kind (Ghdl_Rti_Top.Common.Kind);
+ New_Line;
+ Ctxt := (Base => Ghdl_Rti_Top_Instance,
+ Block => Ghdl_Rti_Top.Parent);
+ Disp_Rti_Arr (Ghdl_Rti_Top.Nbr_Child,
+ Ghdl_Rti_Top.Children,
+ Ctxt, 0);
+ Disp_Rti (Ghdl_Rti_Top.Parent, Ctxt, 0);
+
+ --Disp_Hierarchy;
+ end Disp_All;
+
+ function Disp_Rti_Option (Opt : String) return Boolean
+ is
+ begin
+ if Opt = "--dump-rti" then
+ Disp_Rti_Flag := True;
+ return True;
+ else
+ return False;
+ end if;
+ end Disp_Rti_Option;
+
+ procedure Disp_Rti_Help
+ is
+ procedure P (Str : String) renames Put_Line;
+ begin
+ P (" --dump-rti dump Run Time Information");
+ end Disp_Rti_Help;
+
+ Disp_Rti_Hooks : aliased constant Hooks_Type :=
+ (Option => Disp_Rti_Option'Access,
+ Help => Disp_Rti_Help'Access,
+ Init => null,
+ Start => Disp_All'Access,
+ Finish => null);
+
+ procedure Register is
+ begin
+ Register_Hooks (Disp_Rti_Hooks'Access);
+ end Register;
+
+end Grt.Disp_Rti;