grt-disp_rti.adb

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

   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