Starting to use RTII in vpi interface. Broken. Lots of debug put stat…

…ements.

src/grt/grt-avhpi.adb

@@ -26,6 +26,7 @@ with Grt.Errors; use Grt.Errors;
 with Grt.Vstrings; use Grt.Vstrings;
 with Grt.Rtis_Utils; use Grt.Rtis_Utils;
 with Grt.To_Strings;
+with Grt.Astdio; use Grt.Astdio;
 
 package body Grt.Avhpi is
    procedure Get_Root_Inst (Res : out VhpiHandleT) is
@@ -57,6 +58,7 @@ package body Grt.Avhpi is
                             Res : out VhpiHandleT;
                             Error : out AvhpiErrorT) is
    begin
+      Put("Vhpi_Iterator" & Nl);
       --  Default value in case of success.
       Res := (Kind => VhpiIteratorK,
               Ctxt => Ref.Ctxt,
@@ -143,6 +145,7 @@ package body Grt.Avhpi is
    is
       Child : Ghdl_Object_Rtii;
    begin
+      Put ("Vhpi_Scan_Indexed_Name" & Nl);
       if Iterator.N_Idx = Iterator.N_Size then
          Error := AvhpiErrorIteratorEnd;
          return;
@@ -165,6 +168,7 @@ package body Grt.Avhpi is
       Ch : Ghdl_Rti_Access;
       Nblk : Ghdl_Rtin_Block_Acc;
    begin
+      Put ("Vhpi_Scan_Internal_Regions" & Nl);
       Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
       if Blk = null then
          Error := AvhpiErrorIteratorEnd;
@@ -268,6 +272,7 @@ package body Grt.Avhpi is
                                     Res : out VhpiHandleT;
                                     Error : out AvhpiErrorT) is
    begin
+      Put ("Vhpi_Scan_Root_Design" & Nl);
       if Iterator.It_Cur = 0 then
          Get_Root_Inst (Res);
          Iterator.It_Cur := 1;
@@ -357,6 +362,7 @@ package body Grt.Avhpi is
       Blk : Ghdl_Rtin_Block_Acc;
       Ch : Ghdl_Rti_Access;
    begin
+      Put ("Vhpi_Scan_Decls" & Nl);
       Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
 
       --  If there is no context, returns now.
@@ -430,6 +436,7 @@ package body Grt.Avhpi is
    is
       Blk : Ghdl_Rtin_Block_Acc;
    begin
+      Put ("Vhpi_Scan_Pack_Insts" & Nl);
       Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
       if Iterator.It_Cur >= Blk.Nbr_Child then
          Error := AvhpiErrorIteratorEnd;
@@ -447,6 +454,7 @@ package body Grt.Avhpi is
                         Error : out AvhpiErrorT)
    is
    begin
+      Put ("Vhpi_Scan" & Nl);
       case Iterator.Kind is
          when AvhpiNameIteratorK =>
             case Iterator.N_Obj.Typ.Rti.Kind is
@@ -907,6 +915,14 @@ package body Grt.Avhpi is
       end case;
    end Vhpi_Handle;
 
+   function Vhpi_Handle_From_Rtii (Rtii : Ghdl_Object_Rtii)
+                                  return VhpiHandleT is
+   begin
+      return (Kind => VhpiIndexedNameK,
+              Ctxt => Null_Context,
+              Comp_Obj => Rtii);
+   end Vhpi_Handle_From_Rtii;
+
    procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT;
                                    Ref : VhpiHandleT;
                                    Index : Natural;
@@ -1152,6 +1168,21 @@ package body Grt.Avhpi is
       end case;
    end Avhpi_Get_Rti;
 
+   function Avhpi_Get_Rtii (Obj : VhpiHandleT) return Ghdl_Object_Rtii is
+   begin
+      case Obj.Kind is
+         when VhpiSigDeclK
+           | VhpiPortDeclK
+           | VhpiGenericDeclK
+           | VhpiConstDeclK =>
+            return Obj.Obj;
+         when VhpiIndexedNameK =>
+            return Obj.Comp_Obj;
+         when others =>
+            Internal_Error("avhpi_get_rtii");
+      end case;
+   end Avhpi_Get_Rtii;
+
    function Avhpi_Get_Address (Obj : VhpiHandleT) return Address is
    begin
       case Obj.Kind is

src/grt/grt-avhpi.ads

@@ -432,6 +432,9 @@ package Grt.Avhpi is
                           Res : out VhpiHandleT;
                           Error : out AvhpiErrorT);
 
+   function Vhpi_Handle_From_Rtii (Rtii : Ghdl_Object_Rtii)
+                                  return VhpiHandleT;
+
    procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT;
                                    Ref : VhpiHandleT;
                                    Index : Natural;
@@ -516,6 +519,8 @@ package Grt.Avhpi is
 
    function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access;
 
+   function Avhpi_Get_Rtii (Obj : VhpiHandleT) return Ghdl_Object_Rtii;
+
    function Avhpi_Get_Address (Obj : VhpiHandleT) return Address;
 
    function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context;

src/grt/grt-rtiis.adb

@@ -23,7 +23,12 @@
 --  however invalidate any other reasons why the executable file might be
 --  covered by the GNU Public License.
 
+with System.Address_Image;
 with Grt.Errors; use Grt.Errors;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Signals; use Grt.Signals;
+with Interfaces; use Interfaces;
+
 
 package body Grt.Rtiis is
 
@@ -358,7 +363,7 @@ package body Grt.Rtiis is
             Is_Sig => Rtii.Is_Sig,
             Typ => El_Type,
             Name => El_Name,
-            Name_Ptr => null,
+            Name_Ptr => El_Rti.Name,
             Base_Rti => Rtii.Base_Rti,
             Addr => Child_Addr);
       end if;
@@ -428,6 +433,7 @@ package body Grt.Rtiis is
       Typ : Ghdl_Type_Rtii;
       Rtii : Ghdl_Object_Rtii;
    begin
+      Put("To_Ghdl_Object_Rtii" & Nl);
       case Rti.Common.Kind is
          when Ghdl_Rtik_Port |
               Ghdl_Rtik_Signal =>
@@ -450,9 +456,28 @@ package body Grt.Rtiis is
          when others =>
             Internal_Error("to_ghdl_rtii : Unknown Kind");
       end case;
+      Put("To_Ghdl_Object_Rtii: Sig is " & Boolean'Image(Is_Sig) & Nl);
       Addr := Loc_To_Addr(Depth => Rti.Common.Depth,
                           Loc => Rti.Loc,
                           Ctxt => Ctxt);
+      Put("To_Ghdl_Object_Rtii: Address is " & Address_Image(Addr) & Nl);
+      if Is_Sig then
+         Put ("To_Ghdl_Object_Rtii: It's a signal so...");
+         Put ("address of the signal pointer is.  It is " &
+                System.Address_Image(Addr) & Nl);
+         Put ("value ptr address is " &
+                Address_Image(To_Address(To_Ghdl_Signal_Ptr(Addr).Value_Ptr))
+                & Nl);
+         -- Presumably if it's a signal this is the offset for the location of
+         -- the signal structure.
+         -- Let's assume it's the offset from the current context.
+         --Addr := Loc_To_Addr(Depth => Rti.Common.Depth,
+         --                    Loc => Addr,
+         --                    Ctxt => Ctxt);
+         --Put ("now the value ptr address is " &
+         --       Address_Image(To_Address(To_Ghdl_Signal_Ptr(Addr).Value_Ptr))
+         --       & Nl);
+      end if;
       if Is_Bound(Rti.Obj_Type) then
          Layout_Addr := Get_Type_Layout(Rti.Obj_Type, Ctxt);
          Binding_Layout_Addr := Null_Address;
@@ -567,4 +592,166 @@ package body Grt.Rtiis is
       end case;
    end Get_Size;
 
+   --  Get a child of an Rtii by name.
+   function Get_Rtii_Child_By_Name (Rtii : Ghdl_Object_Rtii; Name : String;
+                                    Child : out Ghdl_Object_Rtii)
+                           return Boolean is
+      Nbr_Children : Ghdl_Index_Type;
+   begin
+      Nbr_Children := Get_Rtii_Nbr_Children(Rtii);
+      for Child_Index in 0 .. Nbr_Children-1 loop
+         Child := Get_Rtii_Child(Rtii, Child_Index);
+         if Child.Name_Ptr(1 .. Name'Length) = Name then
+            return True;
+         end if;
+      end loop;
+      return False;
+   end Get_Rtii_Child_By_Name;
+
+   function Get_Val (Rtii : Ghdl_Object_Rtii) return Ghdl_Value_Ptr is
+      Base_Rti : constant Ghdl_Rtin_Object_Acc := Rtii.Base_Rti;
+      Val : Ghdl_Value_Ptr;
+   begin
+      case Base_Rti.Common.Kind is
+         when Ghdl_Rtik_Port =>
+            case Base_Rti.Common.Mode and Ghdl_Rti_Signal_Mode_Mask is
+               when Ghdl_Rti_Signal_Mode_In
+                 | Ghdl_Rti_Signal_Mode_Inout
+                 | Ghdl_Rti_Signal_Mode_Buffer
+                 | Ghdl_Rti_Signal_Mode_Linkage =>
+                  Put ("Get_Val: port in" & Nl);
+                  Val := To_Ghdl_Signal_Ptr(Rtii.Addr).Value_Ptr;
+               when Ghdl_Rti_Signal_Mode_Out =>
+                  Put ("Get_Val: port out" & Nl);
+                  Val := To_Ghdl_Signal_Ptr(Rtii.Addr).Driving_Value'Access;
+               when others =>
+                  Internal_Error("Get_Val: Bad mode");
+            end case;
+         when Ghdl_Rtik_Signal =>
+            Put ("Get_Val: signal" & Nl);
+            Put ("Get_Val: address of the signal pointer is.  It is " &
+                   System.Address_Image(Rtii.Addr) & Nl);
+            Val := To_Ghdl_Signal_Ptr(Rtii.Addr).Value_Ptr;
+            Put ("Get_Val: got the value pointer.  It is " &
+                   System.Address_Image(To_Address(Val)) & Nl);
+            Put ("Get_Val: Data is ");
+            Put (Integer_32'Image(To_Integer_32(Val.I32)));
+            Put (Nl);
+         when Ghdl_Rtik_Generic
+           | Ghdl_Rtik_Constant =>
+            Put ("Get_Val: generic or constant" & Nl);
+            Val := To_Ghdl_Value_Ptr(Rtii.Addr);
+         when others =>
+            Internal_Error("Get_Val: Bad rti kind");
+      end case;
+      return Val;
+   end Get_Val;
+
+   procedure Append_Bin (V : Ghdl_U64; Ndigits : Natural;
+                         Buf_Value : in out Vstring) is
+   begin
+      for I in reverse 0 .. Ndigits - 1 loop
+         if (Shift_Right (V, I) and 1) /= 0 then
+            Append (Buf_Value, '1');
+         else
+            Append (Buf_Value, '0');
+         end if;
+      end loop;
+   end Append_Bin;
+
+   type Map_Type_E8 is array (Ghdl_E8 range 0..8) of character;
+   Map_Std_E8: constant Map_Type_E8 := "UX01ZWLH-";
+
+   function E8_To_Char (Val : Ghdl_E8) return Character is
+   begin
+      if Val not in Map_Type_E8'range then
+         return '?';
+      else
+         return Map_Std_E8 (Val);
+      end if;
+   end E8_To_Char;
+
+   type Map_Type_B1 is array (Ghdl_B1) of character;
+   Map_Std_B1: constant Map_Type_B1 := "01";
+
+   procedure Append_Simple_Bin_Str (Rtii : Ghdl_Object_Rtii;
+                                    Buf_Value : in out Vstring) is
+      Val : Ghdl_Value_Ptr;
+   begin
+      Put ("Append_Simple_Bin_Str: Start" & Nl);
+      Val := Get_Val(Rtii);
+      Put ("Append_Simple_Bin_Str: Got value" & Nl);
+      case Rtii.Typ.Rti.Kind is
+         when Ghdl_Rtik_Type_B1 =>
+            Append (Buf_Value, Map_Std_B1 (Val.B1));
+         when Ghdl_Rtik_Type_E8 =>
+            Append (Buf_Value, E8_To_Char(Val.E8));
+         when others =>
+            Internal_Error("append_simple_bin_str: unknown type kind");
+      end case;
+   end Append_Simple_Bin_Str;
+
+   procedure Append_Bin_Str (Rtii : Ghdl_Object_Rtii;
+                             Buf_Value : in out Vstring) is
+      Val : constant Ghdl_Value_Ptr := Get_Val(Rtii);
+   begin
+      Put ("Append_Bin_Str: Start" & Nl);
+      case Rtii.Typ.Rti.Kind is
+         when Ghdl_Rtik_Type_Record
+           | Ghdl_Rtik_Subtype_Record =>
+            Internal_Error(
+              "append_bin_str: Cannot get binary string for a record type.");
+         when Ghdl_Rtik_Type_Array
+           | Ghdl_Rtik_Subtype_Array =>
+            for Child_Index in 0 .. Get_Array_Nbr_Children(Rtii) loop
+               Append_Simple_Bin_Str(
+                 Get_Array_Child(Rtii, Child_Index), Buf_Value);
+            end loop;
+         when Ghdl_Rtik_Subtype_Scalar =>
+            case To_Ghdl_Rtin_Subtype_Scalar_Acc(Rtii.Typ.Rti).Basetype.Kind is
+               when Ghdl_Rtik_Type_I32 =>
+                  Put (" Putting I32 down" & Nl);
+                  Append_Bin (Ghdl_U64 (Val.I32), 32, Buf_Value);
+                  Put ("Middle: Buf Value is "); Put(Get_C_String(Buf_Value));
+                  Put(Nl);
+               when Ghdl_Rtik_Type_I64 =>
+                  Put (" Putting I64 down" & Nl);
+                  Append_Bin (Ghdl_U64 (Val.I64), 32, Buf_Value);
+               when others =>
+                  Internal_Error("append_bin_str: Unknown scalar base type");
+            end case;
+         when Ghdl_Rtik_Type_B1 =>
+            Append (Buf_Value, Map_Std_B1 (Val.B1));
+         when Ghdl_Rtik_Type_E8 =>
+            Append (Buf_Value, Map_Std_E8 (Val.E8));
+         when Ghdl_Rtik_Type_E32 =>
+            Append_Bin (Ghdl_U64 (Val.E32), 32, Buf_Value);
+         when Ghdl_Rtik_Type_I32 =>
+            Put (" Putting I32 down" & Nl);
+            Append_Bin (Ghdl_U64 (Val.I32), 32, Buf_Value);
+            Put ("Middle: Buf Value is "); Put(Get_C_String(Buf_Value));
+            Put(Nl);
+         when Ghdl_Rtik_Type_I64 =>
+                  Put (" Putting I64 down" & Nl);
+            Append_Bin (Ghdl_U64 (Val.I64), 32, Buf_Value);
+         when Ghdl_Rtik_Type_F64
+           | Ghdl_Rtik_Type_P32
+           | Ghdl_Rtik_Type_P64
+           | Ghdl_Rtik_Type_Access =>
+            Internal_Error("append_bin_str: Mooooo");
+         when Ghdl_Rtik_Type_Unbounded_Record
+           | Ghdl_Rtik_Type_File =>
+            Internal_Error("append_bin_str: Baaa3");
+         when Ghdl_Rtik_Subtype_Unconstrained_Array =>
+            Internal_Error("append_bin_str: Baaa1");
+         when Ghdl_Rtik_Subtype_Unbounded_Record
+           | Ghdl_Rtik_Subtype_Access
+           | Ghdl_Rtik_Type_Protected
+           | Ghdl_Rtik_Element =>
+            Internal_Error("append_bin_str: Baaa2");
+         when others =>
+            Internal_Error("append_bin_str: unknown type kind");
+      end case;
+   end Append_Bin_Str;
+
 end Grt.Rtiis;

src/grt/grt-rtiis.ads

@@ -26,6 +26,7 @@ with System; use System;
 with Grt.Types; use Grt.Types;
 with Grt.Rtis; use Grt.Rtis;
 with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Vstrings; use Grt.Vstrings;
 
 package Grt.Rtiis is
 
@@ -88,6 +89,11 @@ package Grt.Rtiis is
    function Get_Rtii_Child (Rtii : Ghdl_Object_Rtii; Index : Ghdl_Index_Type)
    return Ghdl_Object_Rtii;
 
+   -- Get a child of an Rtii by the element name.
+   function Get_Rtii_Child_By_Name (Rtii : Ghdl_Object_Rtii; Name : String;
+                                    Child : out Ghdl_Object_Rtii)
+   return Boolean;
+
    --  Get number of children in a Rtii.
    function Get_Rtii_Nbr_Children (Rtii : Ghdl_Object_Rtii)
                                   return Ghdl_Index_Type;
@@ -113,4 +119,7 @@ package Grt.Rtiis is
    --  Whether this is record-like.
    function Is_Record (Rtii : Ghdl_Object_Rtii) return Boolean;
 
+   procedure Append_Bin_Str (Rtii : Ghdl_Object_Rtii;
+                             Buf_Value : in out Vstring);
+
 end Grt.Rtiis;

src/grt/grt-types.ads

@@ -36,6 +36,8 @@ package Grt.Types is
    type Ghdl_U32 is new Unsigned_32;
    subtype Ghdl_E32 is Ghdl_U32;
    type Ghdl_I32 is new Integer_32;
+   function To_Integer_32 is new Ada.Unchecked_Conversion
+     (Ghdl_I32, Integer_32);
    type Ghdl_I64 is new Integer_64;
    type Ghdl_U64 is new Unsigned_64;
    type Ghdl_F64 is new IEEE_Float_64;
@@ -224,6 +226,8 @@ package Grt.Types is
    type Ghdl_Value_Ptr is access all Value_Union;
    function To_Ghdl_Value_Ptr is new Ada.Unchecked_Conversion
      (Source => Address, Target => Ghdl_Value_Ptr);
+   function To_Address is new Ada.Unchecked_Conversion
+     (Source => Ghdl_Value_Ptr, Target => Address);
 
    --  Ranges.
    type Ghdl_Range_B1 is record