rtis: add source location for blocks and object. Use them in fst dumper.

7 files changed, 182 insertions, 11 deletions

diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb
index 690a6bb..434e999 100644
--- a/src/grt/grt-avhpi.adb
+++ b/src/grt/grt-avhpi.adb
@@ -551,6 +551,41 @@ package body Grt.Avhpi is
 
    procedure Vhpi_Get_Str (Property : VhpiStrPropertyT;
                            Obj : VhpiHandleT;
+                           Res : out Ghdl_C_String) is
+   begin
+      Res := null;
+
+      case Property is
+         when VhpiFileNameP =>
+            declare
+               Parent : Ghdl_Rti_Access;
+            begin
+               Parent := Obj.Ctxt.Block;
+               while Parent /= null loop
+                  case Parent.Kind is
+                     when Ghdl_Rtik_Package
+                       | Ghdl_Rtik_Package_Body
+                       | Ghdl_Rtik_Entity
+                       | Ghdl_Rtik_Architecture =>
+                        Res :=
+                          To_Ghdl_Rtin_Block_Filename_Acc (Parent).Filename;
+                        return;
+                     when Ghdl_Rtik_Block
+                       | Ghdl_Rtik_Process =>
+                        Parent :=
+                          To_Ghdl_Rtin_Block_Acc (Parent).Parent;
+                     when others =>
+                        return;
+                  end case;
+               end loop;
+            end;
+         when others =>
+            null;
+      end case;
+   end Vhpi_Get_Str;
+
+   procedure Vhpi_Get_Str (Property : VhpiStrPropertyT;
+                           Obj : VhpiHandleT;
                            Res : out String;
                            Len : out Natural)
    is
@@ -747,6 +782,13 @@ package body Grt.Avhpi is
                      when others =>
                         return;
                   end case;
+               when VhpiCompInstStmtK =>
+                  Res := (Kind => VhpiArchBodyK,
+                          Ctxt => Null_Context);
+                  Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt);
+                  pragma Assert (Ref.Ctxt.Block.Kind = Ghdl_Rtik_Architecture);
+                  Error := AvhpiErrorOk;
+                  return;
                when others =>
                   return;
             end case;
@@ -973,6 +1015,9 @@ package body Grt.Avhpi is
                        Error : out AvhpiErrorT)
    is
    begin
+      --  Default error.
+      Error := AvhpiErrorNotImplemented;
+
       case Property is
          when VhpiLeftBoundP =>
             if Obj.Kind /= VhpiIntRangeK then
@@ -985,9 +1030,9 @@ package body Grt.Avhpi is
                when Ghdl_Rtik_Type_I32 =>
                   Res := Obj.Rng_Addr.I32.Left;
                when others =>
-                  Error := AvhpiErrorNotImplemented;
+                  null;
             end case;
-            return;
+
          when VhpiRightBoundP =>
             if Obj.Kind /= VhpiIntRangeK then
                Error := AvhpiErrorBadRel;
@@ -998,11 +1043,39 @@ package body Grt.Avhpi is
                when Ghdl_Rtik_Type_I32 =>
                   Res := Obj.Rng_Addr.I32.Right;
                when others =>
-                  Error := AvhpiErrorNotImplemented;
+                  null;
             end case;
-            return;
+
+         when VhpiLineNoP =>
+            declare
+               Linecol : Ghdl_Index_Type;
+            begin
+               case Obj.Kind is
+                  when VhpiSigDeclK
+                    | VhpiPortDeclK
+                    | VhpiGenericDeclK =>
+                     --  Objects.
+                     Linecol := Obj.Obj.Linecol;
+                  when VhpiPackInstK
+                    | VhpiArchBodyK
+                    | VhpiEntityDeclK
+                    | VhpiProcessStmtK
+                    | VhpiBlockStmtK
+                    | VhpiIfGenerateK =>
+                     --  Blocks.
+                     Linecol :=
+                       To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Linecol;
+                  when VhpiCompInstStmtK =>
+                     Linecol := Obj.Inst.Linecol;
+                  when others =>
+                     return;
+               end case;
+               Res := VhpiIntT (Linecol / 256);
+               Error := AvhpiErrorOk;
+            end;
+
          when others =>
-            Error := AvhpiErrorNotImplemented;
+            null;
       end case;
    end Vhpi_Get;
 
diff --git a/src/grt/grt-avhpi.ads b/src/grt/grt-avhpi.ads
index e55a1d8..b61b1ff 100644
--- a/src/grt/grt-avhpi.ads
+++ b/src/grt/grt-avhpi.ads
@@ -443,6 +443,10 @@ package Grt.Avhpi is
                            Res : out String;
                            Len : out Natural);
 
+   procedure Vhpi_Get_Str (Property : VhpiStrPropertyT;
+                           Obj : VhpiHandleT;
+                           Res : out Ghdl_C_String);
+
    subtype VhpiIntT is Ghdl_I32;
 
    procedure Vhpi_Get (Property : VhpiIntPropertyT;
diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb
index a8c2d96..bb6f75f 100644
--- a/src/grt/grt-disp_rti.adb
+++ b/src/grt/grt-disp_rti.adb
@@ -624,6 +624,16 @@ package body Grt.Disp_Rti is
       end case;
    end Disp_Subtype_Indication;
 
+   procedure Disp_Linecol (Linecol : Ghdl_Index_Type)
+   is
+      Line : constant Ghdl_U32 := Ghdl_U32 (Linecol / 256);
+      Col : constant Ghdl_U32 := Ghdl_U32 (Linecol mod 256);
+   begin
+      Put ("sloc=");
+      Put_U32 (stdout, Line);
+      Put (":");
+      Put_U32 (stdout, Col);
+   end Disp_Linecol;
 
    procedure Disp_Rti (Rti : Ghdl_Rti_Access;
                        Ctxt : Rti_Context;
@@ -649,9 +659,24 @@ package body Grt.Disp_Rti is
       Disp_Indent (Indent);
       Disp_Kind (Blk.Common.Kind);
       Disp_Depth (Blk.Common.Depth);
+      Put (", ");
+      Disp_Linecol (Blk.Linecol);
       Put (": ");
       Disp_Name (Blk.Name);
       New_Line;
+      case Blk.Common.Kind is
+         when Ghdl_Rtik_Package
+           | Ghdl_Rtik_Package_Body
+           | Ghdl_Rtik_Entity
+           | Ghdl_Rtik_Architecture =>
+            Disp_Indent (Indent);
+            Put (" filename: ");
+            Disp_Name (To_Ghdl_Rtin_Block_Filename_Acc
+                         (To_Ghdl_Rti_Access (Blk)).Filename);
+            New_Line;
+         when others =>
+            null;
+      end case;
       if Blk.Parent /= null then
          case Blk.Common.Kind is
             when Ghdl_Rtik_Architecture =>
@@ -708,6 +733,8 @@ package body Grt.Disp_Rti is
       Disp_Indent (Indent);
       Disp_Kind (Obj.Common.Kind);
       Disp_Depth (Obj.Common.Depth);
+      Put (", ");
+      Disp_Linecol (Obj.Linecol);
       Put ("; ");
       Disp_Name (Obj.Name);
       Put (": ");
@@ -767,6 +794,8 @@ package body Grt.Disp_Rti is
    begin
       Disp_Indent (Indent);
       Disp_Kind (Inst.Common.Kind);
+      Put (", ");
+      Disp_Linecol (Inst.Linecol);
       Put (": ");
       Disp_Name (Inst.Name);
       New_Line;
diff --git a/src/grt/grt-fst.adb b/src/grt/grt-fst.adb
index a44a263..a290dd4 100644
--- a/src/grt/grt-fst.adb
+++ b/src/grt/grt-fst.adb
@@ -288,6 +288,21 @@ package body Grt.Fst is
          end;
       end if;
 
+      --  Source (for instances ?)
+      if Boolean'(False) then
+         declare
+            Filename : Ghdl_C_String;
+            Line : VhpiIntT;
+         begin
+            Vhpi_Get_Str (VhpiFileNameP, Sig, Filename);
+            Vhpi_Get (VhpiLineNoP, Sig, Line, Err);
+            if Filename /= null and then Err = AvhpiErrorOk then
+               fstWriterSetSourceStem
+                 (Context, Filename, Interfaces.C.unsigned (Line), 0);
+            end if;
+         end;
+      end if;
+
       --  Extract type name.
       Vhpi_Handle (VhpiSubtype, Sig, Sig_Type, Err);
       if Err /= AvhpiErrorOk then
@@ -382,7 +397,43 @@ package body Grt.Fst is
    is
       Name : String (1 .. 128);
       Name_Len : Integer;
+      Err : AvhpiErrorT;
    begin
+      --  Source file and line.
+      declare
+         Filename : Ghdl_C_String;
+         Line : VhpiIntT;
+         Arch : VhpiHandleT;
+      begin
+         Vhpi_Get_Str (VhpiFileNameP, Decl, Filename);
+         Vhpi_Get (VhpiLineNoP, Decl, Line, Err);
+         if Filename /= null and then Err = AvhpiErrorOk then
+            if Vhpi_Get_Kind (Decl) /= VhpiCompInstStmtK then
+               --  For a block, a generate block: source location.
+               fstWriterSetSourceStem
+                 (Context, Filename, Interfaces.C.unsigned (Line), 0);
+            else
+               --  For a component instantiation: instance location
+               fstWriterSetSourceInstantiationStem
+                 (Context, Filename, Interfaces.C.unsigned (Line), 0);
+               --  Request DesignUnit => arch
+               Vhpi_Handle (VhpiDesignUnit, Decl, Arch, Err);
+               if Err /= AvhpiErrorOk then
+                  Avhpi_Error (Err);
+               elsif Arch /= Null_Handle then
+                  --  Request filename and line.
+                  Vhpi_Get_Str (VhpiFileNameP, Arch, Filename);
+                  Vhpi_Get (VhpiLineNoP, Arch, Line, Err);
+                  if Filename /= null and then Err = AvhpiErrorOk then
+                     --  And source location.
+                     fstWriterSetSourceStem
+                       (Context, Filename, Interfaces.C.unsigned (Line), 0);
+                  end if;
+               end if;
+            end if;
+         end if;
+      end;
+
       Vhpi_Get_Str (VhpiNameP, Decl, Name, Name_Len);
       if Name_Len < Name'Last then
          Name (Name_Len + 1) := NUL;
diff --git a/src/grt/grt-rtis.ads b/src/grt/grt-rtis.ads
index 6bb7659..b5d307b 100644
--- a/src/grt/grt-rtis.ads
+++ b/src/grt/grt-rtis.ads
@@ -125,6 +125,7 @@ package Grt.Rtis is
       Common : Ghdl_Rti_Common;
       Name : Ghdl_C_String;
       Loc : Ghdl_Rti_Loc;
+      Linecol : Ghdl_Index_Type;
       Parent : Ghdl_Rti_Access;
       Size : Ghdl_Index_Type;
       Nbr_Child : Ghdl_Index_Type;
@@ -136,11 +137,20 @@ package Grt.Rtis is
    function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
      (Source => Ghdl_Rtin_Block_Acc, Target => Ghdl_Rti_Access);
 
+   type Ghdl_Rtin_Block_Filename is record
+      Block : Ghdl_Rtin_Block;
+      Filename : Ghdl_C_String;
+   end record;
+   type Ghdl_Rtin_Block_Filename_Acc is access Ghdl_Rtin_Block_Filename;
+   function To_Ghdl_Rtin_Block_Filename_Acc is new Ada.Unchecked_Conversion
+     (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Block_Filename_Acc);
+
    type Ghdl_Rtin_Object is record
       Common : Ghdl_Rti_Common;
       Name : Ghdl_C_String;
       Loc : Ghdl_Rti_Loc;
       Obj_Type : Ghdl_Rti_Access;
+      Linecol : Ghdl_Index_Type;
    end record;
    type Ghdl_Rtin_Object_Acc is access Ghdl_Rtin_Object;
    function To_Ghdl_Rtin_Object_Acc is new Ada.Unchecked_Conversion
@@ -151,9 +161,10 @@ package Grt.Rtis is
    type Ghdl_Rtin_Instance is record
       Common : Ghdl_Rti_Common;
       Name : Ghdl_C_String;
+      Linecol : Ghdl_Index_Type;
       Loc : Ghdl_Rti_Loc;
       Parent : Ghdl_Rti_Access;
-      Instance : Ghdl_Rti_Access;
+      Instance : Ghdl_Rti_Access; --  Component or entity.
    end record;
    type Ghdl_Rtin_Instance_Acc is access Ghdl_Rtin_Instance;
    function To_Ghdl_Rtin_Instance_Acc is new Ada.Unchecked_Conversion
@@ -348,6 +359,7 @@ package Grt.Rtis is
      (Common => (Ghdl_Rtik_Top, 0, 0, 0),
       Name => null,
       Loc => Null_Rti_Loc,
+      Linecol => 0,
       Parent => null,
       Size => 0,
       Nbr_Child => 0,
diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb
index 70a0e21..d9f746e 100644
--- a/src/grt/grt-rtis_addr.adb
+++ b/src/grt/grt-rtis_addr.adb
@@ -187,15 +187,14 @@ package body Grt.Rtis_Addr is
                                    Ctxt : Rti_Context;
                                    Sub_Ctxt : out Rti_Context)
    is
-      Inst_Addr : Address;
-      Inst_Base : Address;
-   begin
       --  Address of the field containing the address of the instance.
-      Inst_Addr := Ctxt.Base + Inst.Loc;
+      Inst_Addr : constant Address := Ctxt.Base + Inst.Loc;
       --  Read sub instance address.
-      Inst_Base := To_Addr_Acc (Inst_Addr).all;
+      Inst_Base : constant Address := To_Addr_Acc (Inst_Addr).all;
+   begin
       --  Read instance RTI.
       if Inst_Base = Null_Address then
+         --  No instance.
          Sub_Ctxt := (Base => Null_Address, Block => null);
       else
          Sub_Ctxt := (Base => Inst_Base,
diff --git a/src/grt/grt-signals.adb b/src/grt/grt-signals.adb
index 9698d81..2ec5aa2 100644
--- a/src/grt/grt-signals.adb
+++ b/src/grt/grt-signals.adb
@@ -1385,6 +1385,7 @@ package body Grt.Signals is
                  Depth => 0,
                  Mode => Ghdl_Rti_Signal_Mode_None,
                  Max_Depth => 0),
+      Linecol => 0,
       Name => null,
       Loc => Null_Rti_Loc,
       Obj_Type => null);
@@ -1394,6 +1395,7 @@ package body Grt.Signals is
                  Depth => 0,
                  Mode => Ghdl_Rti_Signal_Mode_None,
                  Max_Depth => 0),
+      Linecol => 0,
       Name => null,
       Loc => Null_Rti_Loc,
       Obj_Type => null);
@@ -1475,6 +1477,7 @@ package body Grt.Signals is
                  Depth => 0,
                  Mode => Ghdl_Rti_Signal_Mode_None,
                  Max_Depth => 0),
+      Linecol => 0,
       Name => null,
       Loc => Null_Rti_Loc,
       Obj_Type => Std_Standard_Boolean_RTI_Ptr);