From 687d32b88144d65f153eea439cbf9ce763c2d5c5 Mon Sep 17 00:00:00 2001
From: Tristan Gingold <tgingold@free.fr>
Date: Sat, 13 Dec 2014 07:34:11 +0100
Subject: rtis: add source location for blocks and object. Use them in fst
 dumper.

---
 src/grt/grt-avhpi.adb | 83 +++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 78 insertions(+), 5 deletions(-)

(limited to 'src/grt/grt-avhpi.adb')

diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb
index 690a6bb8f..434e99938 100644
--- a/src/grt/grt-avhpi.adb
+++ b/src/grt/grt-avhpi.adb
@@ -549,6 +549,41 @@ package body Grt.Avhpi is
       end case;
    end Avhpi_Get_Base_Name;
 
+   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;
@@ -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;
 
-- 
cgit v1.2.3