grt-disp_rti.adb

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

--  GHDL Run Time (GRT) - RTI dumper.
--  Copyright (C) 2002, 2003, 2004, 2005 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.
with System; use System;
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.Options; use Grt.Options;

package body Grt.Disp_Rti is
   procedure Disp_Kind (Kind : Ghdl_Rtik);

   procedure Disp_Name (Name : Ghdl_C_String) is
   begin
      if Name = null then
         Put (stdout, "<anonymous>");
      else
         Put (stdout, Name);
      end if;
   end Disp_Name;

   --  Disp value stored at ADDR and whose type is described by RTI.
   procedure Disp_Enum_Value
     (Stream : FILEs; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type)
   is
      Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
   begin
      Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
      Put (Stream, Enum_Rti.Names (Val));
   end Disp_Enum_Value;

   procedure Disp_Scalar_Value
     (Stream : FILEs;
      Rti : Ghdl_Rti_Access;
      Addr : in out Address;
      Is_Sig : Boolean)
   is
      procedure Update (S : Ghdl_Index_Type) is
      begin
         Addr := Addr + (S / Storage_Unit);
      end Update;

      Vptr : Ghdl_Value_Ptr;
   begin
      if Is_Sig then
         Vptr := To_Ghdl_Value_Ptr (To_Addr_Acc (Addr).all);
         Update (Address'Size);
      else
         Vptr := To_Ghdl_Value_Ptr (Addr);
      end if;

      case Rti.Kind is
         when Ghdl_Rtik_Type_I32 =>
            Put_I32 (Stream, Vptr.I32);
            if not Is_Sig then
               Update (32);
            end if;
         when Ghdl_Rtik_Type_E8 =>
            Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E8));
            if not Is_Sig then
               Update (8);
            end if;
         when Ghdl_Rtik_Type_B2 =>
            Disp_Enum_Value (Stream, Rti,
                             Ghdl_Index_Type (Ghdl_B2'Pos (Vptr.B2)));
            if not Is_Sig then
               Update (8);
            end if;
         when Ghdl_Rtik_Type_F64 =>
            Put_F64 (Stream, Vptr.F64);
            if not Is_Sig then
               Update (64);
            end if;
         when Ghdl_Rtik_Type_P64 =>
            Put_I64 (Stream, Vptr.I64);
            Put (Stream, " ");
            Put (Stream,
                 To_Ghdl_Rtin_Unit_Acc
                 (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0)).Name);
            if not Is_Sig then
               Update (64);
            end if;
         when others =>
            Internal_Error ("disp_rti.disp_scalar_value");
      end case;
   end Disp_Scalar_Value;

--    function Get_Scalar_Type_Kind (Rti : Ghdl_Rti_Access) return Ghdl_Rtik
--    is
--       Ndef : Ghdl_Rti_Access;
--    begin
--       if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then
--          Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype;
--       else
--          Ndef := Rti;
--       end if;
--       case Ndef.Kind is
--          when Ghdl_Rtik_Type_I32 =>
--             return Ndef.Kind;
--          when others =>
--             return Ghdl_Rtik_Error;
--       end case;
--    end Get_Scalar_Type_Kind;

   procedure Disp_Value (Stream : FILEs;
                         Rti : Ghdl_Rti_Access;
                         Ctxt : Rti_Context;
                         Obj : in out Address;
                         Is_Sig : Boolean);

   procedure Disp_Array_Value_1 (Stream : FILEs;
                                 El_Rti : Ghdl_Rti_Access;
                                 Ctxt : Rti_Context;
                                 Rngs : Ghdl_Range_Array;
                                 Rtis : Ghdl_Rti_Arr_Acc;
                                 Index : Ghdl_Index_Type;
                                 Obj : in out Address;
                                 Is_Sig : Boolean)
   is
      Length : Ghdl_Index_Type;
   begin
      Length := Range_To_Length (Rngs (Index), Get_Base_Type (Rtis (Index)));
      Put (Stream, "(");
      for I in 1 .. Length loop
         if I /= 1 then
            Put (Stream, ", ");
         end if;
         if Index = Rngs'Last then
            Disp_Value (Stream, El_Rti, Ctxt, Obj, Is_Sig);
         else
            Disp_Array_Value_1
              (Stream, El_Rti, Ctxt, Rngs, Rtis, Index + 1, Obj, Is_Sig);
         end if;
      end loop;
      Put (Stream, ")");
   end Disp_Array_Value_1;

   procedure Disp_Array_Value (Stream : FILEs;
                               Rti : Ghdl_Rtin_Type_Array_Acc;
                               Ctxt : Rti_Context;
                               Vals : Ghdl_Uc_Array_Acc;
                               Is_Sig : Boolean)
   is
      Nbr_Dim : Ghdl_Index_Type := Rti.Nbr_Dim;
      Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1);
      Obj : Address;
   begin
      Bound_To_Range (Vals.Bounds, Rti, Rngs);
      Obj := Vals.Base;
      Disp_Array_Value_1
        (Stream, Rti.Element, Ctxt, Rngs, Rti.Indexes, 0, Obj, Is_Sig);
   end Disp_Array_Value;

   procedure Disp_Record_Value (Stream : FILEs;
                                Rti : Ghdl_Rtin_Type_Record_Acc;
                                Ctxt : Rti_Context;
                                Obj : in out Address;
                                Is_Sig : Boolean)
   is
      El : Ghdl_Rtin_Element_Acc;
      El_Addr : Address;
   begin
      Put (Stream, "(");
      for I in 1 .. Rti.Nbrel loop
         El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1));
         if I /= 1 then
            Put (", ");
         end if;
         Put (Stream, El.Name);
         Put (" => ");
         if Is_Sig then
            El_Addr := Obj + El.Sig_Off;
         else
            El_Addr := Obj + El.Val_Off;
         end if;
         Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Is_Sig);
      end loop;
      Put (")");
      --  FIXME: update ADDR.
   end Disp_Record_Value;

   procedure Disp_Value
     (Stream : FILEs;
      Rti : Ghdl_Rti_Access;
      Ctxt : Rti_Context;
      Obj : in out Address;
      Is_Sig : Boolean)
   is
   begin
      case Rti.Kind is
         when Ghdl_Rtik_Subtype_Scalar =>
            Disp_Scalar_Value
              (Stream, To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype,
               Obj, Is_Sig);
         when Ghdl_Rtik_Type_I32
           | Ghdl_Rtik_Type_E8
           | Ghdl_Rtik_Type_B2 =>
            Disp_Scalar_Value (Stream, Rti, Obj, Is_Sig);
         when Ghdl_Rtik_Type_Array =>
            Disp_Array_Value (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt,
                              To_Ghdl_Uc_Array_Acc (Obj), Is_Sig);
         when Ghdl_Rtik_Subtype_Array =>
            declare
               St : Ghdl_Rtin_Subtype_Array_Acc :=
                 To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
               Bt : Ghdl_Rtin_Type_Array_Acc := St.Basetype;
               Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
               B : Address;
            begin
               Bound_To_Range
                 (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs);
               B := Obj;
               Disp_Array_Value_1
                 (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig);
            end;
         when Ghdl_Rtik_Subtype_Array_Ptr =>
            declare
               St : Ghdl_Rtin_Subtype_Array_Acc :=
                 To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
               Bt : Ghdl_Rtin_Type_Array_Acc := St.Basetype;
               Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
               B : Address;
            begin
               Bound_To_Range
                 (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs);
               B := To_Addr_Acc (Obj).all;
               Disp_Array_Value_1
                 (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig);
            end;
         when Ghdl_Rtik_Type_File =>
            declare
               Vptr : Ghdl_Value_Ptr;
            begin
               Vptr := To_Ghdl_Value_Ptr (Obj);
               Put (Stream, "File#");
               Put_I32 (Stream, Vptr.I32);
               --  FIXME: update OBJ (not very useful since never in a
               --   composite type).
            end;
         when Ghdl_Rtik_Type_Record =>
            Disp_Record_Value
              (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Is_Sig);
         when others =>
            Put (Stream, "??");
      end case;
   end Disp_Value;

   procedure Disp_Kind (Kind : Ghdl_Rtik) is
   begin
      case Kind is
         when Ghdl_Rtik_Top =>
            Put ("ghdl_rtik_top");
         when Ghdl_Rtik_Package =>
            Put ("ghdl_rtik_package");
         when Ghdl_Rtik_Package_Body =>
            Put ("ghdl_rtik_package_body");
         when Ghdl_Rtik_Entity =>
            Put ("ghdl_rtik_entity");
         when Ghdl_Rtik_Architecture =>
            Put ("ghdl_rtik_architecture");

         when Ghdl_Rtik_Port =>
            Put ("ghdl_rtik_port");
         when Ghdl_Rtik_Generic =>
            Put ("ghdl_rtik_generic");
         when Ghdl_Rtik_Process =>
            Put ("ghdl_rtik_process");
         when Ghdl_Rtik_Component =>
            Put ("ghdl_rtik_component");
         when Ghdl_Rtik_Attribute =>
            Put ("ghdl_rtik_attribute");

         when Ghdl_Rtik_Attribute_Quiet =>
            Put ("ghdl_rtik_attribute_quiet");
         when Ghdl_Rtik_Attribute_Stable =>
            Put ("ghdl_rtik_attribute_stable");
         when Ghdl_Rtik_Attribute_Transaction =>
            Put ("ghdl_rtik_attribute_transaction");

         when Ghdl_Rtik_Constant =>
            Put ("ghdl_rtik_constant");
         when Ghdl_Rtik_Iterator =>
            Put ("ghdl_rtik_iterator");
         when Ghdl_Rtik_Signal =>
            Put ("ghdl_rtik_signal");
         when Ghdl_Rtik_Variable =>
            Put ("ghdl_rtik_variable");
         when Ghdl_Rtik_Guard =>
            Put ("ghdl_rtik_guard");
         when Ghdl_Rtik_File =>
            Put ("ghdl_rtik_file");

         when Ghdl_Rtik_Instance =>
            Put ("ghdl_rtik_instance");
         when Ghdl_Rtik_Block =>
            Put ("ghdl_rtik_block");
         when Ghdl_Rtik_If_Generate =>
            Put ("ghdl_rtik_if_generate");
         when Ghdl_Rtik_For_Generate =>
            Put ("ghdl_rtik_for_generate");

         when Ghdl_Rtik_Type_B2 =>
            Put ("ghdl_rtik_type_b2");
         when Ghdl_Rtik_Type_E8 =>
            Put ("ghdl_rtik_type_e8");
         when Ghdl_Rtik_Type_P64 =>
            Put ("ghdl_rtik_type_p64");
         when Ghdl_Rtik_Type_I32 =>
            Put ("ghdl_rtik_type_i32");

         when Ghdl_Rtik_Type_Array =>
            Put ("ghdl_rtik_type_array");
         when Ghdl_Rtik_Subtype_Array =>
            Put ("ghdl_rtik_subtype_array");
         when Ghdl_Rtik_Subtype_Array_Ptr =>
            Put ("ghdl_rtik_subtype_array_ptr");
         when Ghdl_Rtik_Type_Record =>
            Put ("ghdl_rtik_type_record");

         when Ghdl_Rtik_Type_Access =>
            Put ("ghdl_rtik_type_access");
         when Ghdl_Rtik_Type_File =>
            Put ("ghdl_rtik_type_file");

         when Ghdl_Rtik_Subtype_Scalar =>
            Put ("ghdl_rtik_subtype_scalar");