grt-waves.adb

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

      return Strcmp (Ls, Rs);
   end Str_Compare;

   procedure Disp_Str_Avl (N : AVL_Nid) is
   begin
      Put (stdout, "node: ");
      Put_I32 (stdout, Ghdl_I32 (N));
      New_Line (stdout);
      Put (stdout, " left: ");
      Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Left));
      New_Line (stdout);
      Put (stdout, " right: ");
      Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Right));
      New_Line (stdout);
      Put (stdout, " height: ");
      Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Height));
      New_Line (stdout);
      Put (stdout, " str: ");
      --Put (stdout, Str_AVL.Table (N).Val);
      New_Line (stdout);
   end Disp_Str_Avl;

   function Create_Str_Index (Str : Ghdl_C_String) return AVL_Value
   is
      Res : AVL_Nid;
   begin
      Str_Table.Append (Str);
      Str_AVL.Append (AVL_Node'(Val => Str_Table.Last,
                                Left | Right => AVL_Nil,
                                Height => 1));
      Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)),
                Str_Compare'Access,
                Str_AVL.Last, Res);
      if Res /= Str_AVL.Last then
         Str_AVL.Decrement_Last;
         Str_Table.Decrement_Last;
      else
         Strings_Len := Strings_Len + strlen (Str);
      end if;
      return Str_AVL.Table (Res).Val;
   end Create_Str_Index;

   procedure Create_String_Id (Str : Ghdl_C_String)
   is
      Res : AVL_Nid;
   begin
      if Str = null then
         return;
      end if;
      Str_Table.Append (Str);
      Str_AVL.Append (AVL_Node'(Val => Str_Table.Last,
                                Left | Right => AVL_Nil,
                                Height => 1));
      Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)),
                Str_Compare'Access,
                Str_AVL.Last, Res);
      if Res /= Str_AVL.Last then
         Str_AVL.Decrement_Last;
         Str_Table.Decrement_Last;
      else
         Strings_Len := Strings_Len + strlen (Str);
      end if;
   end Create_String_Id;

   function Get_String (Str : Ghdl_C_String) return AVL_Value
   is
      H, L, M : AVL_Value;
      Diff : Integer;
   begin
      L := Str_Table.First;
      H := Str_Table.Last;
      loop
         M := (L + H) / 2;
         Diff := Strcmp (Str, Str_Table.Table (M));
         if Diff = 0 then
            return M;
         elsif Diff < 0 then
            H := M - 1;
         else
            L := M + 1;
         end if;
         exit when L > H;
      end loop;
      return 0;
   end Get_String;

   procedure Write_String_Id (Str : Ghdl_C_String) is
   begin
      if Str = null then
         Wave_Put_Byte (0);
      else
         Wave_Put_ULEB128 (Ghdl_E32 (Get_String (Str)));
      end if;
   end Write_String_Id;

   type Type_Node is record
      Type_Rti : Ghdl_Rti_Access;
      Context : Rti_Context;
   end record;

   package Types_Table is new GNAT.Table
     (Table_Component_Type => Type_Node,
      Table_Index_Type => AVL_Value,
      Table_Low_Bound => 1,
      Table_Initial => 16,
      Table_Increment => 100);

   package Types_AVL is new GNAT.Table
     (Table_Component_Type => AVL_Node,
      Table_Index_Type => AVL_Nid,
      Table_Low_Bound => AVL_Root,
      Table_Initial => 16,
      Table_Increment => 100);

   function Type_Compare (L, R : AVL_Value) return Integer
   is
      use System;
      function To_Ia is new
        Ada.Unchecked_Conversion (Ghdl_Rti_Access, Integer_Address);

      function "<" (L, R : Ghdl_Rti_Access) return Boolean is
      begin
         return To_Ia (L) < To_Ia (R);
      end "<";

      Ls : Type_Node renames Types_Table.Table (L);
      Rs : Type_Node renames Types_Table.Table (R);
   begin
      if Ls.Type_Rti /= Rs.Type_Rti then
         if Ls.Type_Rti < Rs.Type_Rti then
            return -1;
         else
            return 1;
         end if;
      end if;
      if Ls.Context.Block /= Rs.Context.Block then
         if Ls.Context.Block < Rs.Context.Block then
            return -1;
         else
            return +1;
         end if;
      end if;
      if Ls.Context.Base /= Rs.Context.Base then
         if Ls.Context.Base < Rs.Context.Base then
            return -1;
         else
            return +1;
         end if;
      end if;
      return 0;
   end Type_Compare;

   --  Try to find typr (RTI, CTXT) in the types_AVL table.
   --  The first step is to canonicalize CTXT, so that it is the CTXT of
   --   the type (and not a sub-scope of it).
   procedure Find_Type (Rti : Ghdl_Rti_Access;
                        Ctxt : Rti_Context;
                        N_Ctxt : out Rti_Context;
                        Id : out AVL_Nid)
   is
      Depth : Ghdl_Rti_Depth;
   begin
      case Rti.Kind is
         when Ghdl_Rtik_Type_B2
           | Ghdl_Rtik_Type_E8 =>
            N_Ctxt := Null_Context;
         when others =>
            --  Compute the canonical context.
            if Rti.Max_Depth < Rti.Depth then
               Internal_Error ("grt.waves.find_type");
            end if;
            Depth := Rti.Max_Depth;
            if Depth = 0 or else Ctxt.Block = null then
               N_Ctxt := Null_Context;
            else
               N_Ctxt := Ctxt;
               while N_Ctxt.Block.Depth > Depth loop
                  N_Ctxt := Get_Parent_Context (N_Ctxt);
               end loop;
            end if;
      end case;

      --  If the type is already known, return now.
      --  Otherwise, ID is set to AVL_Nil.
      Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => N_Ctxt));
      Id := Find_Node
        (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)),
         Type_Compare'Access,
         Types_Table.Last);
      Types_Table.Decrement_Last;
   end Find_Type;

   procedure Write_Type_Id (Tid : AVL_Nid) is
   begin
      Wave_Put_ULEB128 (Ghdl_E32 (Types_AVL.Table (Tid).Val));
   end Write_Type_Id;

   procedure Write_Type_Id (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
   is
      N_Ctxt : Rti_Context;
      Res : AVL_Nid;
   begin
      Find_Type (Rti, Ctxt, N_Ctxt, Res);
      if Res = AVL_Nil then
         -- raise Program_Error;
         Internal_Error ("write_type_id");
      end if;
      Write_Type_Id (Res);
   end Write_Type_Id;

   procedure Create_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
   is
      N_Ctxt : Rti_Context;
      Res : AVL_Nid;
   begin
      Find_Type (Rti, Ctxt, N_Ctxt, Res);
      if Res /= AVL_Nil then
         return;
      end if;

      --  First, create all the types it depends on.
      case Rti.Kind is
         when Ghdl_Rtik_Type_B2
           | Ghdl_Rtik_Type_E8 =>
            declare
               Enum : Ghdl_Rtin_Type_Enum_Acc;
            begin
               Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
               Create_String_Id (Enum.Name);
               for I in 1 .. Enum.Nbr loop
                  Create_String_Id (Enum.Names (I - 1));
               end loop;
            end;
         when Ghdl_Rtik_Subtype_Array
           | Ghdl_Rtik_Subtype_Array_Ptr =>
            declare
               Arr : Ghdl_Rtin_Subtype_Array_Acc;
            begin
               Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
               Create_String_Id (Arr.Name);
               if Rti.Mode = 1 then
                  N_Ctxt := Ctxt;
               end if;
               Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), N_Ctxt);
            end;
         when Ghdl_Rtik_Type_Array =>
            declare
               Arr : Ghdl_Rtin_Type_Array_Acc;
            begin
               Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti);
               Create_String_Id (Arr.Name);
               Create_Type (Arr.Element, N_Ctxt);
               for I in 1 .. Arr.Nbr_Dim loop
                  Create_Type (Arr.Indexes (I - 1), N_Ctxt);
               end loop;
            end;
         when Ghdl_Rtik_Subtype_Scalar =>
            declare
               Sub : Ghdl_Rtin_Subtype_Scalar_Acc;
            begin
               Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
               Create_String_Id (Sub.Name);
               Create_Type (Sub.Basetype, N_Ctxt);
            end;
         when Ghdl_Rtik_Type_I32
           | Ghdl_Rtik_Type_I64
           | Ghdl_Rtik_Type_F64 =>
            declare
               Base : Ghdl_Rtin_Type_Scalar_Acc;
            begin
               Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
               Create_String_Id (Base.Name);
            end;
         when Ghdl_Rtik_Type_P32
           | Ghdl_Rtik_Type_P64 =>
            declare
               Base : Ghdl_Rtin_Type_Physical_Acc;
               Unit : Ghdl_Rtin_Unit_Acc;
            begin
               Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
               Create_String_Id (Base.Name);
               for I in 1 .. Base.Nbr loop
                  Unit := To_Ghdl_Rtin_Unit_Acc (Base.Units (I - 1));
                  Create_String_Id (Unit.Name);
               end loop;
            end;
         when Ghdl_Rtik_Type_Record =>
            declare
               Rec : Ghdl_Rtin_Type_Record_Acc;
               El : Ghdl_Rtin_Element_Acc;
            begin
               Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti);
               Create_String_Id (Rec.Name);
               for I in 1 .. Rec.Nbrel loop
                  El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1));
                  Create_String_Id (El.Name);
                  Create_Type (El.Eltype, N_Ctxt);
               end loop;
            end;
         when others =>
            Internal_Error ("wave.create_type");
--              Internal_Error ("wave.create_type: does not handle " &
--                             Ghdl_Rtik'Image (Rti.Kind));
      end case;

      --  Then, create the type.
      Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => N_Ctxt));
      Types_AVL.Append (AVL_Node'(Val => Types_Table.Last,
                                  Left | Right => AVL_Nil,
                                  Height => 1));

      Get_Node
        (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)),
         Type_Compare'Access,
         Types_AVL.Last, Res);
      if Res /= Types_AVL.Last then
         --raise Program_Error;
         Internal_Error ("wave.create_type(2)");
      end if;
   end Create_Type;

   procedure Create_Object_Type (Obj : VhpiHandleT)
   is
      Obj_Type : VhpiHandleT;
      Error : AvhpiErrorT;
   begin
      --  Extract type of the signal.
      Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error);
      if Error /= AvhpiErrorOk then
         Avhpi_Error (Error);
         return;
      end if;
      Create_Type (Avhpi_Get_Rti (Obj_Type), Avhpi_Get_Context (Obj_Type));
   end Create_Object_Type;

   procedure Write_Object_Type (Obj : VhpiHandleT)
   is
      Obj_Type : VhpiHandleT;
      Error : AvhpiErrorT;
   begin
      --  Extract type of the signal.
      Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error);
      if Error /= AvhpiErrorOk then
         Avhpi_Error (Error);
         return;
      end if;
      Write_Type_Id (Avhpi_Get_Rti (Obj_Type), Avhpi_Get_Context (Obj_Type));
   end Write_Object_Type;

   procedure Create_Generate_Type (Gen : VhpiHandleT)
   is
      Iterator : VhpiHandleT;
      Error : AvhpiErrorT;
   begin
      --  Extract the iterator.
      Vhpi_Handle (VhpiIterScheme, Gen, Iterator, Error);
      if Error /= AvhpiErrorOk then
         Avhpi_Error (Error);
         return;
      end if;
      Create_Object_Type (Iterator);
   end Create_Generate_Type;

   procedure Write_Generate_Type_And_Value (Gen : VhpiHandleT)
   is
      Iter : VhpiHandleT;
      Iter_Type : VhpiHandleT;
      Error : AvhpiErrorT;
      Addr : Address;
      Mode : Mode_Type;
      Rti : Ghdl_Rti_Access;
   begin
      --  Extract the iterator.