diff options
Diffstat (limited to 'src/translate/grt/grt-disp_tree.adb')
| -rw-r--r-- | src/translate/grt/grt-disp_tree.adb | 461 |
1 files changed, 0 insertions, 461 deletions
diff --git a/src/translate/grt/grt-disp_tree.adb b/src/translate/grt/grt-disp_tree.adb deleted file mode 100644 index 7d58119..0000000 --- a/src/translate/grt/grt-disp_tree.adb +++ /dev/null @@ -1,461 +0,0 @@ --- GHDL Run Time (GRT) - Tree displayer. --- 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 System; use System; -with Grt.Disp_Rti; use Grt.Disp_Rti; -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.Hooks; use Grt.Hooks; - -package body Grt.Disp_Tree is - -- Set by --disp-tree, to display the design hierarchy. - type Disp_Tree_Kind is - ( - Disp_Tree_None, -- Do not disp tree. - Disp_Tree_Inst, -- Disp entities, arch, package, blocks, components. - Disp_Tree_Proc, -- As above plus processes - Disp_Tree_Port -- As above plus ports and signals. - ); - Disp_Tree_Flag : Disp_Tree_Kind := Disp_Tree_None; - - - -- 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_Flag >= Disp_Tree_Port then - return; - end if; - when Ghdl_Rtik_Process => - if Disp_Tree_Flag >= 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 : constant 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 : constant 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 : constant Ghdl_Rtin_Block_Acc := - To_Ghdl_Rtin_Block_Acc (Child); - Nctxt : Rti_Context; - begin - Nctxt := (Base => Ctxt.Base + Nblk.Loc, - Block => Child); - Disp_Header (Nctxt, False); - Disp_Sub_Block (Nblk, Nctxt); - end; - when Ghdl_Rtik_For_Generate => - declare - Nblk : constant 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).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 : constant Ghdl_Rtin_Block_Acc := - To_Ghdl_Rtin_Block_Acc (Child); - Nctxt : Rti_Context; - begin - Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).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_Flag >= 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 - if Disp_Tree_Flag = Disp_Tree_None then - return; - end if; - - 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.Nbr_Child loop - Child := Ghdl_Rti_Top.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; - - function Disp_Tree_Option (Option : String) return Boolean - is - Opt : constant String (1 .. Option'Length) := Option; - begin - if Opt'Length >= 11 and then Opt (1 .. 11) = "--disp-tree" then - if Opt'Length = 11 then - Disp_Tree_Flag := Disp_Tree_Port; - elsif Opt (12 .. Opt'Last) = "=port" then - Disp_Tree_Flag := Disp_Tree_Port; - elsif Opt (12 .. Opt'Last) = "=proc" then - Disp_Tree_Flag := Disp_Tree_Proc; - elsif Opt (12 .. Opt'Last) = "=inst" then - Disp_Tree_Flag := Disp_Tree_Inst; - elsif Opt (12 .. Opt'Last) = "=none" then - Disp_Tree_Flag := Disp_Tree_None; - else - Error ("bad argument for --disp-tree option, try --help"); - end if; - return True; - else - return False; - end if; - end Disp_Tree_Option; - - procedure Disp_Tree_Help - is - procedure P (Str : String) renames Put_Line; - begin - P (" --disp-tree[=KIND] disp the design hierarchy after elaboration"); - P (" KIND is inst, proc, port (default)"); - end Disp_Tree_Help; - - Disp_Tree_Hooks : aliased constant Hooks_Type := - (Option => Disp_Tree_Option'Access, - Help => Disp_Tree_Help'Access, - Init => null, - Start => Disp_Hierarchy'Access, - Finish => null); - - procedure Register is - begin - Register_Hooks (Disp_Tree_Hooks'Access); - end Register; - -end Grt.Disp_Tree; |