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.Errors; use Grt.Errors;
with Grt.To_Strings; use Grt.To_Strings;
with Grt.Vstrings_IO; use Grt.Vstrings_IO;

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
                 | Ghdl_Rtik_Case_Generate =>
                  Nctxt := Get_If_Case_Generate_Child (Ctxt, Child);
                  if Nctxt.Base /= Null_Address then
                     Res := Traverse_Blocks_1 (Nctxt);
                  end if;
               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 others =>
                  Res := Process (Ctxt, Child);
            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 Object_To_Base_Bounds (Obj_Type : Ghdl_Rti_Access;
                                    Obj_Loc : Address;
                                    Addr : out Address;
                                    Bounds : out Address) is
   begin
      --  FIXME: put this into a function.
      Bounds := Null_Address;
      Addr := Obj_Loc;
      case Obj_Type.Kind is
         when  Ghdl_Rtik_Subtype_Array
           | Ghdl_Rtik_Type_Record
           | Ghdl_Rtik_Subtype_Record =>
            --  If the type is complex then the location
            --  contains a pointer to the instantiation data.
            if Rti_Complex_Type (Obj_Type) then
               Addr := To_Addr_Acc (Obj_Loc).all;
            end if;
         when Ghdl_Rtik_Type_Array
           | Ghdl_Rtik_Type_Unbounded_Record
           | Ghdl_Rtik_Subtype_Unbounded_Record =>
            --  If the type is unbounded then the location
            --  for the object containts a pointer to the bounds
            --  and a pointer to the data.
            Bounds := To_Ghdl_Uc_Array_Acc (Obj_Loc).Bounds;
            Addr := To_Ghdl_Uc_Array_Acc (Obj_Loc).Base;
         when others =>
            null;
      end case;
   end Object_To_Base_Bounds;

   procedure Record_To_Element (Obj : Address;
                                El : Ghdl_Rtin_Element_Acc;
                                Is_Sig : Boolean;
                                Rec_Layout : Address;
                                El_Addr : out Address;
                                El_Bounds : out Address)
   is
      Off : Ghdl_Index_Type;
      Off_Addr : Address;
   begin
      if Is_Sig then
         Off := El.Sig_Off;
      else
         Off := El.Val_Off;
      end if;

      case El.Common.Mode is
         when Ghdl_Rti_Element_Static =>
            El_Addr := Obj + Off;
            El_Bounds := Null_Address;
         when Ghdl_Rti_Element_Complex =>
            Off_Addr := Rec_Layout + Off;
            El_Addr := Obj + To_Ghdl_Index_Ptr (Off_Addr).all;
            El_Bounds := Null_Address;
         when Ghdl_Rti_Element_Unbounded =>
            Off_Addr := Rec_Layout + Off;
            El_Addr := Obj + To_Ghdl_Index_Ptr (Off_Addr).all;
            El_Bounds := Rec_Layout + El.Layout_Off;
            if El.Eltype.Kind = Ghdl_Rtik_Type_Array then
               El_Bounds := Array_Layout_To_Bounds (El_Bounds);
            end if;
         when others =>
            Internal_Error ("record_to_element");
      end case;
   end Record_To_Element;

   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;
      Bounds : 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 (Arr_Rti : Ghdl_Rtin_Type_Array_Acc;
                                Index : Ghdl_Index_Type)
      is
         Idx_Rti : constant Ghdl_Rti_Access := Arr_Rti.Indexes (Index);
         Base_Type : constant Ghdl_Rti_Access := Get_Base_Type (Idx_Rti);
         El_Rti : constant Ghdl_Rti_Access := Arr_Rti.Element;
         Last_Index : constant Ghdl_Index_Type := Arr_Rti.Nbr_Dim - 1;
         Rng : Ghdl_Range_Ptr;
         Len : Ghdl_Index_Type;
         P : Natural;
         Cur_Bounds : Address;
      begin
         P := Length (Name);
         if Index = 0 then
            Append (Name, '(');
         else
            Append (Name, ',');
         end if;

         Extract_Range (Bounds, Base_Type, Rng);
         Len := Range_To_Length (Rng, Base_Type);

         Cur_Bounds := Bounds;
         for I in 1 .. Len loop
            Pos_To_Vstring (Name, Base_Type, Rng, I - 1);
            if Index = Last_Index then
               --  FIXME: not always needed.
               Bounds := Array_Layout_To_Bounds (Cur_Bounds);
               Append (Name, ')');
               Handle_Any (El_Rti);
            else
               Bounds := Cur_Bounds;
               Handle_Array_1 (Arr_Rti, Index + 1);
            end if;
            Truncate (Name, P + 1);
         end loop;
         Truncate (Name, P);
      end Handle_Array_1;

      procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc)
      is
         Rec_Addr : constant Address := Addr;
         Rec_Bounds : constant Address := Bounds;
         Sizes : constant Ghdl_Indexes_Ptr :=
           To_Ghdl_Indexes_Ptr (Bounds);
         El : Ghdl_Rtin_Element_Acc;
         P : Natural;
      begin
         P := Length (Name);
         for I in 1 .. Rti.Nbrel loop
            El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1));
            Record_To_Element
              (Rec_Addr, El, Is_Sig, Rec_Bounds, Addr, Bounds);
            Append (Name, '.');
            Append (Name, El.Name);
            Handle_Any (El.Eltype);
            Truncate (Name, P);
         end loop;
         if Is_Sig then
            Addr := Rec_Addr + Sizes.Signal;
         else
            Addr := Rec_Addr + Sizes.Value;
         end if;
         --  Bounds was fully used, no need to restore it.
         Bounds := Null_Address;
      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_1 (To_Ghdl_Rtin_Type_Array_Acc (Rti), 0);
            when Ghdl_Rtik_Subtype_Array =>
               declare
                  St : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                    To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
                  Bt : constant Ghdl_Rtin_Type_Array_Acc :=
                    To_Ghdl_Rtin_Type_Array_Acc (St.Basetype);
                  Prev_Bounds : constant Address := Bounds;
                  Layout : Address;
               begin
                  Layout := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt);
                  Bounds := Array_Layout_To_Bounds (Layout);
                  Handle_Array_1 (Bt, 0);
                  Bounds := Prev_Bounds;
               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 =>
               declare
                  Bt : constant Ghdl_Rtin_Type_Record_Acc :=
                    To_Ghdl_Rtin_Type_Record_Acc (Rti);
                  Prev_Bounds : constant Address := Bounds;
               begin
                  Bounds := Loc_To_Addr (Bt.Common.Depth, Bt.Layout, Ctxt);
                  Handle_Record (Bt);
                  Bounds := Prev_Bounds;
               end;
            when Ghdl_Rtik_Type_Unbounded_Record =>
               --  Bounds (layout) must have been extracted.
               Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti));
            when Ghdl_Rtik_Subtype_Unbounded_Record =>
               declare
                  St : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                    To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
                  Bt : constant Ghdl_Rtin_Type_Record_Acc :=
                    To_Ghdl_Rtin_Type_Record_Acc (St.Basetype);
               begin
                  Handle_Record (Bt);
               end;
            when Ghdl_Rtik_Subtype_Record =>
               declare
                  St : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                    To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
                  Bt : constant Ghdl_Rtin_Type_Record_Acc :=
                    To_Ghdl_Rtin_Type_Record_Acc (St.Basetype);
                  Prev_Bounds : constant Address := Bounds;
               begin
                  Bounds := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt);
                  Handle_Record (Bt);
                  Bounds := Prev_Bounds;
               end;
            when others =>
               Internal_Error ("grt.rtis_utils.foreach_scalar.handle_any");
         end case;
      end Handle_Any;
   begin
      Object_To_Base_Bounds (Obj_Type, Obj_Addr, Addr, Bounds);
      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);
         if Blk = null then
            Prepend (Rstr, "???");
            return;
         end if;
         case Ctxt.Block.Kind is
            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_Process
              | Ghdl_Rtik_Block =>
               Prepend (Rstr, Blk.Name);
               Prepend (Rstr, Sep);
               Ctxt := Get_Parent_Context (Ctxt);
            when Ghdl_Rtik_Generate_Body =>
               declare
                  Gen : constant Ghdl_Rtin_Generate_Acc :=
                    To_Ghdl_Rtin_Generate_Acc (Blk.Parent);
                  Iter : Ghdl_Rtin_Object_Acc;
                  Addr : Address;
               begin
                  if Blk.Parent.Kind = Ghdl_Rtik_For_Generate then
                     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, '(');
                  end if;
                  Prepend (Rstr, Gen.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;

   function Get_Linecol_Line (Linecol : Ghdl_Index_Type) return Ghdl_U32 is
   begin
      return Ghdl_U32 (Linecol / 256);
   end Get_Linecol_Line;

   function Get_Linecol_Col (Linecol : Ghdl_Index_Type) return Ghdl_U32 is
   begin
      return Ghdl_U32 (Linecol mod 256);
   end Get_Linecol_Col;

   function Get_Filename (Ctxt : Rti_Context) return Ghdl_C_String
   is
      C : Rti_Context;
   begin
      C := Ctxt;
      loop
         case C.Block.Kind is
            when Ghdl_Rtik_Package
              | Ghdl_Rtik_Package_Body
              | Ghdl_Rtik_Architecture
              | Ghdl_Rtik_Entity =>
               declare
                  Blk : constant Ghdl_Rtin_Block_Filename_Acc :=
                    To_Ghdl_Rtin_Block_Filename_Acc (C.Block);
               begin
                  return Blk.Filename;
               end;
            when others =>
               C := Get_Parent_Context (C);
         end case;
      end loop;
   end Get_Filename;
end Grt.Rtis_Utils;