grt-disp_rti.adb

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

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