grt-disp_rti.adb

vhdl集成电路设计软件.需要用gcc-4.0.2版本编译.

              | 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;