-- 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.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, ""); 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 or Obj_Type.Kind = Ghdl_Rtik_Type_Record) 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;