path: root/src/grt/grt-disp_tree.adb

--  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
               Gen : constant Ghdl_Rtin_Generate_Acc :=
                 To_Ghdl_Rtin_Generate_Acc (Rti);
               Bod : constant Ghdl_Rtin_Block_Acc :=
                 To_Ghdl_Rtin_Block_Acc (Gen.Child);
               Iter : constant Ghdl_Rtin_Object_Acc :=
                 To_Ghdl_Rtin_Object_Acc (Bod.Children (0));
               Addr : Address;
            begin
               Disp_Name (Gen.Name);
               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;
            Put ("]");
         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
                  Gen : constant Ghdl_Rtin_Generate_Acc :=
                    To_Ghdl_Rtin_Generate_Acc (Child);
                  Nctxt : Rti_Context;
                  Length : Ghdl_Index_Type;
                  Old_Child2 : Ghdl_Rti_Access;
               begin
                  Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all,
                            Block => Gen.Child);
                  Length := Get_For_Generate_Length (Gen, 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
                       (To_Ghdl_Rtin_Block_Acc (Gen.Child), Nctxt);
                     if I /= Length then
                        Nctxt.Base := Nctxt.Base + Gen.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
                  Nctxt : constant Rti_Context :=
                    Get_If_Generate_Child (Ctxt, Child);
               begin
                  Disp_Header (Nctxt);
                  if Nctxt.Base /= Null_Address then
                     Disp_Sub_Block
                       (To_Ghdl_Rtin_Block_Acc (Nctxt.Block), 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 :=
     (Desc => new String'
        ("disp-tree: display design hierarchy (--disp-tree)"),
      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;