grt-rtis_utils.adb

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

         Handle_Array_1 (Rti.Element, Rngs, Rti.Indexes, 0);
      end Handle_Array;

      procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc)
      is
         El : Ghdl_Rtin_Element_Acc;
         Obj_Addr : Address;
         P : Natural;
      begin
         P := Length (Name);
         Obj_Addr := Addr;
         for I in 1 .. Rti.Nbrel loop
            El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1));
            if Is_Sig then
               Addr := Obj_Addr + El.Sig_Off;
            else
               Addr := Obj_Addr + El.Val_Off;
            end if;
            Append (Name, '.');
            Append (Name, El.Name);
            Handle_Any (El.Eltype);
            Truncate (Name, P);
         end loop;
         -- FIXME
         --Addr := Obj_Addr + Rti.Xx;
      end Handle_Record;

      procedure Handle_Any (Rti : Ghdl_Rti_Access)
      is
         Save_Addr : Address;
      begin
         case Rti.Kind is
            when Ghdl_Rtik_Subtype_Scalar =>
               Handle_Scalar (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype);
            when Ghdl_Rtik_Type_I32
              | Ghdl_Rtik_Type_E8
              | Ghdl_Rtik_Type_B2 =>
               Handle_Scalar (Rti);
            when Ghdl_Rtik_Type_Array =>
               Handle_Array (To_Ghdl_Rtin_Type_Array_Acc (Rti),
                             To_Ghdl_Uc_Array_Acc (Addr));
            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);
               begin
                  Bound_To_Range
                    (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs);
                  if Rti_Complex_Type (Rti) then
                     Save_Addr := Addr;
                     Addr := To_Addr_Acc (Addr).all;
                  end if;
                  Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0);
                  if Rti_Complex_Type (Rti) then
                     Addr := Save_Addr + (Address'Size / Storage_Unit);
                  end if;
               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);
               begin
                  Bound_To_Range
                    (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs);
                  Save_Addr := Addr;
                  Addr := To_Addr_Acc (Addr).all;
                  Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0);
                  Addr := Save_Addr + (Address'Size / Storage_Unit);
               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 =>
               if Rti_Complex_Type (Rti) then
                  Save_Addr := Addr;
                  Addr := To_Addr_Acc (Addr).all;
               end if;
               Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti));
               if Rti_Complex_Type (Rti) then
                  Addr := Save_Addr + (Address'Size / Storage_Unit);
               end if;
            when others =>
               Internal_Error ("grt.rtis_utils.foreach_scalar.handle_any");
         end case;
      end Handle_Any;
   begin
      Addr := Obj_Addr;
      Handle_Any (Obj_Type);
      Free (Name);
   end Foreach_Scalar;

   procedure Get_Value (Str : in out Vstring;
                        Value : Value_Union;
                        Type_Rti : Ghdl_Rti_Access)
   is
   begin
      case Type_Rti.Kind is
         when Ghdl_Rtik_Type_I32 =>
            declare
               S : String (1 .. 12);
               F : Natural;
            begin
               To_String (S, F, Value.I32);
               Append (Str, S (F .. S'Last));
            end;
         when Ghdl_Rtik_Type_E8 =>
            Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E8));
         when Ghdl_Rtik_Type_B2 =>
            Get_Enum_Value
              (Str, Type_Rti, Ghdl_Index_Type (Ghdl_B2'Pos (Value.B2)));
         when Ghdl_Rtik_Type_F64 =>
            declare
               S : String (1 .. 32);
               L : Integer;
               --  Warning: this assumes a C99 snprintf (ie, it returns the
               --  number of characters).
               function snprintf (Cstr : Address;
                                  Size : Natural;
                                  Template : Address;
                                  Arg : Ghdl_F64)
                 return Integer;
               pragma Import (C, snprintf);

               Format : constant String := "%g" & Character'Val (0);
            begin
               L := snprintf (S'Address, S'Length, Format'Address, Value.F64);
               if L < 0 then
                  --  FIXME.
                  Append (Str, "?");
               else
                  Append (Str, S (1 .. L));
               end if;
            end;
         when Ghdl_Rtik_Type_P32 =>
            declare
               S : String (1 .. 12);
               F : Natural;
            begin
               To_String (S, F, Value.I32);
               Append (Str, S (F .. S'Last));
               Append (Str,
                       To_Ghdl_Rtin_Unit_Acc (To_Ghdl_Rtin_Type_Physical_Acc
                                              (Type_Rti).Units (0)).Name);
            end;
         when Ghdl_Rtik_Type_P64 =>
            declare
               S : String (1 .. 21);
               F : Natural;
            begin
               To_String (S, F, Value.I64);
               Append (Str, S (F .. S'Last));
               Append (Str,
                       To_Ghdl_Rtin_Unit_Acc (To_Ghdl_Rtin_Type_Physical_Acc
                                              (Type_Rti).Units (0)).Name);
            end;
         when others =>
            Internal_Error ("grt.rtis_utils.get_value");
      end case;
   end Get_Value;

   procedure Disp_Value (Stream : FILEs;
                         Value : Value_Union;
                         Type_Rti : Ghdl_Rti_Access)
   is
      Name : Vstring;
   begin
      Rtis_Utils.Get_Value (Name, Value, Type_Rti);
      Put (Stream, Name);
   end Disp_Value;

   procedure Get_Enum_Value
     (Rstr : in out Rstring; 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);
      Prepend (Rstr, Enum_Rti.Names (Val));
   end Get_Enum_Value;


   procedure Get_Value (Rstr : in out Rstring;
                        Addr : Address;
                        Type_Rti : Ghdl_Rti_Access)
   is
      Value : Ghdl_Value_Ptr := To_Ghdl_Value_Ptr (Addr);
   begin
      case Type_Rti.Kind is
         when Ghdl_Rtik_Type_I32 =>
            declare
               S : String (1 .. 12);
               F : Natural;
            begin
               To_String (S, F, Value.I32);
               Prepend (Rstr, S (F .. S'Last));
            end;
         when Ghdl_Rtik_Type_E8 =>
            Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E8));
         when Ghdl_Rtik_Type_B2 =>
            Get_Enum_Value
              (Rstr, Type_Rti, Ghdl_Index_Type (Ghdl_B2'Pos (Value.B2)));
         when others =>
            Internal_Error ("grt.rtis_utils.get_value(rstr)");
      end case;
   end Get_Value;

   procedure Get_Path_Name (Rstr : in out Rstring;
                            Last_Ctxt : Rti_Context;
                            Sep : Character;
                            Is_Instance : Boolean := True)
   is
      Blk : Ghdl_Rtin_Block_Acc;
      Ctxt : Rti_Context;
   begin
      Ctxt := Last_Ctxt;
      loop
         Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
         case Ctxt.Block.Kind is
            when Ghdl_Rtik_Process
              | Ghdl_Rtik_Block
              | Ghdl_Rtik_If_Generate =>
               Prepend (Rstr, Blk.Name);
               Prepend (Rstr, Sep);
               Ctxt := Get_Parent_Context (Ctxt);
            when Ghdl_Rtik_Entity =>
               declare
                  Link : Ghdl_Entity_Link_Acc;
               begin
                  Link := To_Ghdl_Entity_Link_Acc (Ctxt.Base);
                  Ctxt := (Base => Ctxt.Base,
                           Block => Link.Rti);
               end;
            when Ghdl_Rtik_Architecture =>
               declare
                  Entity_Ctxt: Rti_Context;
                  Link : Ghdl_Entity_Link_Acc;
                  Parent_Inst : Ghdl_Rti_Access;
               begin
                  --  Architecture name.
                  if Is_Instance then
                     Prepend (Rstr, ')');
                     Prepend (Rstr, Blk.Name);
                     Prepend (Rstr, '(');
                  end if;

                  Entity_Ctxt := Get_Parent_Context (Ctxt);

                  --  Instance parent.
                  Link := To_Ghdl_Entity_Link_Acc (Entity_Ctxt.Base);
                  Get_Instance_Link (Link, Ctxt, Parent_Inst);

                  --  Add entity name.
                  if Is_Instance or Parent_Inst = null then
                     Prepend (Rstr,
                              To_Ghdl_Rtin_Block_Acc (Entity_Ctxt.Block).Name);
                  end if;

                  if Parent_Inst = null then
                     --  Top reached.
                     Prepend (Rstr, Sep);
                     return;
                  else
                     --  Instantiation statement label.
                     if Is_Instance then
                        Prepend (Rstr, '@');
                     end if;
                     Prepend (Rstr,
                              To_Ghdl_Rtin_Object_Acc (Parent_Inst).Name);
                     Prepend (Rstr, Sep);
                  end if;
               end;
            when Ghdl_Rtik_For_Generate =>
               declare
                  Iter : Ghdl_Rtin_Object_Acc;
                  Addr : Address;
               begin
                  Prepend (Rstr, ')');
                  Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
                  Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
                  Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type));
                  Prepend (Rstr, '(');
                  Prepend (Rstr, Blk.Name);
                  Prepend (Rstr, Sep);
                  Ctxt := Get_Parent_Context (Ctxt);
               end;
            when others =>
               Internal_Error ("grt.rtis_utils.get_path_name");
         end case;
      end loop;
   end Get_Path_Name;

   procedure Put (Stream : FILEs; Ctxt : Rti_Context)
   is
      Rstr : Rstring;
   begin
      Get_Path_Name (Rstr, Ctxt, '.');
      Put (Stream, Rstr);
      Free (Rstr);
   end Put;

end Grt.Rtis_Utils;