diff options
Diffstat (limited to 'src/translate/grt/grt-disp_rti.adb')
| -rw-r--r-- | src/translate/grt/grt-disp_rti.adb | 1080 |
1 files changed, 0 insertions, 1080 deletions
diff --git a/src/translate/grt/grt-disp_rti.adb b/src/translate/grt/grt-disp_rti.adb deleted file mode 100644 index 08d27da..0000000 --- a/src/translate/grt/grt-disp_rti.adb +++ /dev/null @@ -1,1080 +0,0 @@ --- 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; |