grt-rtis_utils.adb

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

--  GHDL Run Time (GRT) - RTI utilities.
--  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.Types; use Grt.Types;
--with Grt.Disp; use Grt.Disp;
with Grt.Errors; use Grt.Errors;

package body Grt.Rtis_Utils is

   function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result
   is
      function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result;

      function Traverse_Blocks_1 (Ctxt : Rti_Context) return Traverse_Result
      is
         Blk : Ghdl_Rtin_Block_Acc;

         Res : Traverse_Result;
         Nctxt : Rti_Context;
         Index : Ghdl_Index_Type;
         Child : Ghdl_Rti_Access;
      begin
         Res := Process (Ctxt, Ctxt.Block);
         if Res /= Traverse_Ok then
            return Res;
         end if;

         Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
         Index := 0;
         while Index < Blk.Nbr_Child loop
            Child := Blk.Children (Index);
            Index := Index + 1;
            case Child.Kind is
               when Ghdl_Rtik_Process
                 | Ghdl_Rtik_Block =>
                  declare
                     Nblk : Ghdl_Rtin_Block_Acc;
                  begin
                     Nblk := To_Ghdl_Rtin_Block_Acc (Child);
                     Nctxt := (Base => Ctxt.Base + Nblk.Loc.Off,
                               Block => Child);
                     Res := Traverse_Blocks_1 (Nctxt);
                  end;
               when Ghdl_Rtik_For_Generate =>
                  declare
                     Nblk : Ghdl_Rtin_Block_Acc;
                     Length : Ghdl_Index_Type;
                  begin
                     Nblk := To_Ghdl_Rtin_Block_Acc (Child);
                     Nctxt :=
                       (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all,
                        Block => Child);
                     Length := Get_For_Generate_Length (Nblk, Ctxt);
                     for I in 1 .. Length loop
                        Res := Traverse_Blocks_1 (Nctxt);
                        exit when Res = Traverse_Stop;
                        Nctxt.Base := Nctxt.Base + Nblk.Size;
                     end loop;
                  end;
               when Ghdl_Rtik_If_Generate =>
                  declare
                     Nblk : Ghdl_Rtin_Block_Acc;
                  begin
                     Nblk := To_Ghdl_Rtin_Block_Acc (Child);
                     Nctxt :=
                       (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all,
                        Block => Child);
                     if Nctxt.Base /= Null_Address then
                        Res := Traverse_Blocks_1 (Nctxt);
                     end if;
                  end;
               when Ghdl_Rtik_Instance =>
                  Res := Process (Ctxt, Child);
                  if Res = Traverse_Ok then
                     declare
                        Obj : Ghdl_Rtin_Instance_Acc;
                     begin
                        Obj := To_Ghdl_Rtin_Instance_Acc (Child);

                        Get_Instance_Context (Obj, Ctxt, Nctxt);
                        Res := Traverse_Instance (Nctxt);
                     end;
                  end if;
               when Ghdl_Rtik_Package
                 | Ghdl_Rtik_Entity
                 | Ghdl_Rtik_Architecture =>
                  Internal_Error ("traverse_blocks");
               when Ghdl_Rtik_Port
                 | Ghdl_Rtik_Signal
                 | Ghdl_Rtik_Guard
                 | Ghdl_Rtik_Attribute_Quiet
                 | Ghdl_Rtik_Attribute_Stable
                 | Ghdl_Rtik_Attribute_Transaction =>
                  Res := Process (Ctxt, Child);
               when others =>
                  null;
            end case;
            exit when Res = Traverse_Stop;
         end loop;

         return Res;
      end Traverse_Blocks_1;

      function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result
      is
         Blk : Ghdl_Rtin_Block_Acc;

         Res : Traverse_Result;
         Nctxt : Rti_Context;

      begin
         Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
         case Blk.Common.Kind is
            when Ghdl_Rtik_Architecture =>
               Nctxt := (Base => Ctxt.Base,
                         Block => Blk.Parent);
               --  The entity.
               Res := Traverse_Blocks_1 (Nctxt);
               if Res /= Traverse_Stop then
                  --  The architecture.
                  Res := Traverse_Blocks_1 (Ctxt);
               end if;
            when Ghdl_Rtik_Package_Body =>
               Nctxt := (Base => Ctxt.Base,
                         Block => Blk.Parent);
               Res := Traverse_Blocks_1 (Nctxt);
            when others =>
               Internal_Error ("traverse_blocks");
         end case;
         return Res;
      end Traverse_Instance;
   begin
      return Traverse_Instance (Ctxt);
   end Traverse_Blocks;

   function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean
   is
   begin
      return (Atype.Mode and Ghdl_Rti_Type_Complex_Mask)
        = Ghdl_Rti_Type_Complex;
   end Rti_Complex_Type;

   --  Disp value stored at ADDR and whose type is described by RTI.
   procedure Get_Enum_Value
     (Vstr : in out Vstring; 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);
      Append (Vstr, Enum_Rti.Names (Val));
   end Get_Enum_Value;


   procedure Foreach_Scalar (Ctxt : Rti_Context;
                             Obj_Type : Ghdl_Rti_Access;
                             Obj_Addr : Address;
                             Is_Sig : Boolean)
   is
      --  Current address.
      Addr : Address;

      Name : Vstring;

      procedure Handle_Any (Rti : Ghdl_Rti_Access);

      procedure Handle_Scalar (Rti : Ghdl_Rti_Access)
      is
         procedure Update (S : Ghdl_Index_Type) is
         begin
            Addr := Addr + (S / Storage_Unit);
         end Update;
      begin
         Process (Addr, Name, Rti);

         if Is_Sig then
            Update (Address'Size);
         else
            case Rti.Kind is
               when Ghdl_Rtik_Type_I32 =>
                  Update (32);
               when Ghdl_Rtik_Type_E8 =>
                  Update (8);
               when Ghdl_Rtik_Type_B2 =>
                  Update (8);
               when Ghdl_Rtik_Type_F64 =>
                  Update (64);
               when Ghdl_Rtik_Type_P64 =>
                  Update (64);
               when others =>
                  Internal_Error ("handle_scalar");
            end case;
         end if;
      end Handle_Scalar;

      procedure Range_Pos_To_Val (Rti : Ghdl_Rti_Access;
                                  Rng : Ghdl_Range_Ptr;
                                  Pos : Ghdl_Index_Type;
                                  Val : out Value_Union)
      is
      begin
         case Rti.Kind is
            when Ghdl_Rtik_Type_I32 =>
               case Rng.I32.Dir is
                  when Dir_To =>
                     Val.I32 := Rng.I32.Left + Ghdl_I32 (Pos);
                  when Dir_Downto =>
                     Val.I32 := Rng.I32.Left - Ghdl_I32 (Pos);
               end case;
            when Ghdl_Rtik_Type_E8 =>
               case Rng.E8.Dir is
                  when Dir_To =>
                     Val.E8 := Rng.E8.Left + Ghdl_E8 (Pos);
                  when Dir_Downto =>
                     Val.E8 := Rng.E8.Left - Ghdl_E8 (Pos);
               end case;
            when Ghdl_Rtik_Type_B2 =>
               case Pos is
                  when 0 =>
                     Val.B2 := Rng.B2.Left;
                  when 1 =>
                     Val.B2 := Rng.B2.Right;
                  when others =>
                     Val.B2 := False;
               end case;
            when others =>
               Internal_Error ("grt.rtis_utils.range_pos_to_val");
         end case;
      end Range_Pos_To_Val;

      procedure Pos_To_Vstring
        (Vstr : in out Vstring;
         Rti : Ghdl_Rti_Access;
         Rng : Ghdl_Range_Ptr;
         Pos : Ghdl_Index_Type)
      is
         V : Value_Union;
      begin
         Range_Pos_To_Val (Rti, Rng, Pos, V);
         case Rti.Kind is
            when Ghdl_Rtik_Type_I32 =>
               declare
                  S : String (1 .. 12);
                  F : Natural;
               begin
                  To_String (S, F, V.I32);
                  Append (Vstr, S (F .. S'Last));
               end;
            when Ghdl_Rtik_Type_E8 =>
               Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E8));
            when Ghdl_Rtik_Type_B2 =>
               Get_Enum_Value (Vstr, Rti, Ghdl_B2'Pos (V.B2));
            when others =>
               Append (Vstr, '?');
         end case;
      end Pos_To_Vstring;

      procedure Handle_Array_1 (El_Rti : Ghdl_Rti_Access;
                                Rngs : Ghdl_Range_Array;
                                Rtis : Ghdl_Rti_Arr_Acc;
                                Index : Ghdl_Index_Type)
      is
         Len : Ghdl_Index_Type;
         P : Natural;
         Base_Type : Ghdl_Rti_Access;
      begin
         P := Length (Name);
         if Index = 0 then
            Append (Name, '(');
         else
            Append (Name, ',');
         end if;

         Base_Type := Get_Base_Type (Rtis (Index));
         Len := Range_To_Length (Rngs (Index),  Base_Type);

         for I in 1 .. Len loop
            Pos_To_Vstring (Name, Base_Type, Rngs (Index), I - 1);
            if Index = Rngs'Last then
               Append (Name, ')');
               Handle_Any (El_Rti);
            else
               Handle_Array_1 (El_Rti, Rngs, Rtis, Index + 1);
            end if;
            Truncate (Name, P + 1);
         end loop;
         Truncate (Name, P);
      end Handle_Array_1;

      procedure Handle_Array (Rti : Ghdl_Rtin_Type_Array_Acc;
                              Vals : Ghdl_Uc_Array_Acc)
      is
         Nbr_Dim : Ghdl_Index_Type := Rti.Nbr_Dim;
         Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1);
      begin
         Bound_To_Range (Vals.Bounds, Rti, Rngs);
         Addr := Vals.Base;