path: root/src/grt/grt-rtis_utils.adb

--  GHDL Run Time (GRT) - RTI utilities.
--  Copyright (C) 2002 - 2014 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.
--
--  As a special exception, if other files instantiate generics from this
--  unit, or you link this unit with other files to produce an executable,
--  this unit does not by itself cause the resulting executable to be
--  covered by the GNU General Public License. This exception does not
--  however invalidate any other reasons why the executable file might be
--  covered by the GNU Public License.
--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,
                               Block => Child);
                     Res := Traverse_Blocks_1 (Nctxt);
                  end;
               when Ghdl_Rtik_For_Generate =>
                  declare
                     Gen : constant Ghdl_Rtin_Generate_Acc :=
                       To_Ghdl_Rtin_Generate_Acc (Child);
                     Length : Ghdl_Index_Type;
                  begin
                     Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all,
                               Block => Gen.Child);
                     Length := Get_For_Generate_Length (Gen, Ctxt);
                     for I in 1 .. Length loop
                        Res := Traverse_Blocks_1 (Nctxt);
                        exit when Res = Traverse_Stop;
                        Nctxt.Base := Nctxt.Base + Gen.Size;
                     end loop;
                  end;
               when Ghdl_Rtik_If_Generate =>
                  declare
                     Gen : constant Ghdl_Rtin_Generate_Acc :=
                       To_Ghdl_Rtin_Generate_Acc (Child);
                  begin
                     Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all,
                               Block => Gen.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);
                        if Nctxt /= Null_Context then
                           Res := Traverse_Instance (Nctxt);
                        end if;
                     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;

   --  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;
                             Param : Param_Type)
   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, Param);

         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_E32 =>
                  Update (32);
               when Ghdl_Rtik_Type_B1 =>
                  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_E32 =>
               case Rng.E32.Dir is
                  when Dir_To =>
                     Val.E32 := Rng.E32.Left + Ghdl_E32 (Pos);
                  when Dir_Downto =>
                     Val.E32 := Rng.E32.Left - Ghdl_E32 (Pos);
               end case;
            when Ghdl_Rtik_Type_B1 =>
               case Pos is
                  when 0 =>
                     Val.B1 := Rng.B1.Left;
                  when 1 =>
                     Val.B1 := Rng.B1.Right;
                  when others =>
                     Val.B1 := 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_E32 =>
               Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E32));
            when Ghdl_Rtik_Type_B1 =>
               Get_Enum_Value (Vstr, Rti, Ghdl_B1'Pos (V.B1));
            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 : constant 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;
         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;
         Last_Addr : Address;
         P : Natural;
      begin
         P := Length (Name);
         Obj_Addr := Addr;
         Last_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;
            if Rti_Complex_Type (El.Eltype) then
               Addr := Obj_Addr + To_Ghdl_Index_Acc (Addr).all;
            end if;
            Append (Name, '.');
            Append (Name, El.Name);
            Handle_Any (El.Eltype);
            if Addr > Last_Addr then
               Last_Addr := Addr;
            end if;
            Truncate (Name, P);
         end loop;
         Addr := Last_Addr;
      end Handle_Record;

      procedure Handle_Any (Rti : Ghdl_Rti_Access) is
      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_E32
              | Ghdl_Rtik_Type_B1 =>
               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 : constant Ghdl_Rtin_Subtype_Array_Acc :=
                    To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
                  Bt : constant 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);
                  Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0);
               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 =>
               Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti));
            when others =>
               Internal_Error ("grt.rtis_utils.foreach_scalar.handle_any");
         end case;
      end Handle_Any;
   begin
      if Rti_Complex_Type (Obj_Type) then
         Addr := To_Addr_Acc (Obj_Addr).all;
      else
         Addr := Obj_Addr;
      end if;
      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_E32 =>
            Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E32));
         when Ghdl_Rtik_Type_B1 =>
            Get_Enum_Value
              (Str, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1)));
         when Ghdl_Rtik_Type_F64 =>
            declare
               S : String (1 .. 32);
               L : Integer;

               function Snprintf_G (Cstr : Address;
                                    Size : Natural;
                                    Arg : Ghdl_F64)
                 return Integer;
               pragma Import (C, Snprintf_G, "__ghdl_snprintf_g");

            begin
               L := Snprintf_G (S'Address, S'Length, 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, Get_Physical_Unit_Name
                    (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0)));
            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, Get_Physical_Unit_Name
                    (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0)));
            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);
      Free (Name);
   end Disp_Value;

   function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access)
                                   return Ghdl_C_String
   is
   begin
      case Unit.Kind is
         when Ghdl_Rtik_Unit64 =>
            return To_Ghdl_Rtin_Unit64_Acc (Unit).Name;
         when Ghdl_Rtik_Unitptr =>
            return To_Ghdl_Rtin_Unitptr_Acc (Unit).Name;
         when others =>
            Internal_Error ("rtis_utils.physical_unit_name");
      end case;
   end Get_Physical_Unit_Name;

   function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access;
                                     Type_Rti : Ghdl_Rti_Access)
                                    return Ghdl_I64 is
   begin
      case Unit.Kind is
         when Ghdl_Rtik_Unit64 =>
            return To_Ghdl_Rtin_Unit64_Acc (Unit).Value;
         when Ghdl_Rtik_Unitptr =>
            case Type_Rti.Kind is
               when Ghdl_Rtik_Type_P64 =>
                  return To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64;
               when Ghdl_Rtik_Type_P32 =>
                  return Ghdl_I64
                    (To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32);
               when others =>
                  Internal_Error ("get_physical_unit_value(1)");
            end case;
         when others =>
            Internal_Error ("get_physical_unit_value(2)");
      end case;
   end Get_Physical_Unit_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 : constant 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_E32 =>
            Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E32));
         when Ghdl_Rtik_Type_B1 =>
            Get_Enum_Value
              (Rstr, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1)));
         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);
                  if Ctxt.Block = null then
                     --  Process in an entity.
                     --  FIXME: check.
                     Prepend (Rstr, Blk.Name);
                     return;
                  end if;
               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;