First import from sources

1 files changed, 456 insertions, 0 deletions

diff --git a/translate/grt/grt-disp_signals.adb b/translate/grt/grt-disp_signals.adb
new file mode 100644
index 0000000..ab73b2d
--- /dev/null
+++ b/translate/grt/grt-disp_signals.adb
@@ -0,0 +1,456 @@
+--  GHDL Run Time (GRT) - Display subprograms for signals.
+--  Copyright (C) 2002, 2003, 2004, 2005 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.
+with System; use System;
+with Ada.Unchecked_Conversion;
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Errors; use Grt.Errors;
+pragma Elaborate_All (Grt.Rtis_Utils);
+with Grt.Vstrings; use Grt.Vstrings;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Signals; use Grt.Signals;
+with Grt.Options;
+with Grt.Disp; use Grt.Disp;
+
+package body Grt.Disp_Signals is
+   procedure Disp_Context (Ctxt : Rti_Context)
+   is
+      Blk : Ghdl_Rtin_Block_Acc;
+      Nctxt : Rti_Context;
+   begin
+      Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+      case Blk.Common.Kind is
+         when Ghdl_Rtik_Block
+           | Ghdl_Rtik_Process =>
+            Nctxt := Get_Parent_Context (Ctxt);
+            Disp_Context (Nctxt);
+            Put ('.');
+            Put (Blk.Name);
+         when Ghdl_Rtik_Entity =>
+            Put (Blk.Name);
+         when Ghdl_Rtik_Architecture =>
+            Nctxt := Get_Parent_Context (Ctxt);
+            Disp_Context (Nctxt);
+            Put ('(');
+            Put (Blk.Name);
+            Put (')');
+         when others =>
+            Internal_Error ("disp_context");
+      end case;
+   end Disp_Context;
+
+   --  Option --trace-signals.
+
+   --  Disp transaction TRANS from signal SIG.
+   procedure Disp_Transaction (Trans : Transaction_Acc;
+                               Sig_Type : Ghdl_Rti_Access;
+                               Mode : Mode_Type)
+   is
+      T : Transaction_Acc;
+   begin
+      T := Trans;
+      loop
+         case T.Kind is
+            when Trans_Value =>
+               if Sig_Type /= null then
+                  Disp_Value (stdout, T.Val, Sig_Type);
+               else
+                  Disp_Value (T.Val, Mode);
+               end if;
+            when Trans_Null =>
+               Put ("NULL");
+            when Trans_Error =>
+               Put ("ERROR");
+         end case;
+         Put ("@");
+         Put_Time (stdout, T.Time);
+         T := T.Next;
+         exit when T = null;
+         Put (", ");
+      end loop;
+   end Disp_Transaction;
+
+   procedure Disp_Simple_Signal
+     (Sig : Ghdl_Signal_Ptr; Sig_Type : Ghdl_Rti_Access; Sources : Boolean)
+   is
+   begin
+      Put (' ');
+      Put (stdout, Sig.all'Address);
+      Put (' ');
+      Disp_Mode (Sig.Mode);
+      Put (' ');
+      if Sig.Active then
+         Put ('A');
+      else
+         Put ('-');
+      end if;
+      if Sig.Event then
+         Put ('E');
+      else
+         Put ('-');
+      end if;
+      if Sig.S.Effective /= null then
+         Put ('e');
+      else
+         Put ('-');
+      end if;
+      if Boolean'(True) then
+         Put (" last_event=");
+         Put_Time (stdout, Sig.Last_Event);
+         Put (" last_active=");
+         Put_Time (stdout, Sig.Last_Active);
+      end if;
+      Put (" val=");
+      if Sig_Type /= null then
+         Disp_Value (stdout, Sig.Value, Sig_Type);
+      else
+         Disp_Value (Sig.Value, Sig.Mode);
+      end if;
+      Put ("; drv=");
+      if Sig_Type /= null then
+         Disp_Value (stdout, Sig.Driving_Value, Sig_Type);
+      else
+         Disp_Value (Sig.Driving_Value, Sig.Mode);
+      end if;
+      if Sources then
+         if Sig.Nbr_Ports > 0 then
+            Put (';');
+            Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports));
+            Put (" ports");
+         end if;
+         if Sig.S.Mode_Sig in Mode_Signal_User then
+            if Sig.S.Nbr_Drivers = 0 then
+               Put ("; no driver");
+            elsif Sig.S.Nbr_Drivers = 1 then
+               Put ("; trans=");
+               Disp_Transaction
+                 (Sig.S.Drivers (0).First_Trans, Sig_Type, Sig.Mode);
+            else
+               for I in 0 .. Sig.S.Nbr_Drivers - 1 loop
+                  New_Line;
+                  Put ("   ");
+                  Disp_Transaction
+                    (Sig.S.Drivers (I).First_Trans, Sig_Type, Sig.Mode);
+               end loop;
+            end if;
+         end if;
+      end if;
+      New_Line;
+   end Disp_Simple_Signal;
+
+   procedure Disp_Scalar_Signal (Val_Addr : Address;
+                                 Val_Name : Vstring;
+                                 Val_Type : Ghdl_Rti_Access)
+   is
+   begin
+      Put (stdout, Val_Name);
+      Disp_Simple_Signal (To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all),
+                          Val_Type, Options.Disp_Sources);
+   end Disp_Scalar_Signal;
+
+   procedure Foreach_Scalar_Signal is new
+     Foreach_Scalar (Process => Disp_Scalar_Signal);
+
+   procedure Disp_Signal_Name (Stream : FILEs; Sig : Ghdl_Rtin_Object_Acc) is
+   begin
+      case Sig.Common.Kind is
+         when Ghdl_Rtik_Signal
+           | Ghdl_Rtik_Port
+           | Ghdl_Rtik_Guard =>
+            Put (Stream, Sig.Name);
+         when Ghdl_Rtik_Attribute_Quiet =>
+            Put (Stream, " 'quiet");
+         when Ghdl_Rtik_Attribute_Stable =>
+            Put (Stream, " 'stable");
+         when Ghdl_Rtik_Attribute_Transaction =>
+            Put (Stream, " 'quiet");
+         when others =>
+            null;
+      end case;
+   end Disp_Signal_Name;
+
+   function Disp_Signal (Ctxt : Rti_Context;
+                         Obj : Ghdl_Rti_Access)
+                        return Traverse_Result
+   is
+      Sig : Ghdl_Rtin_Object_Acc;
+   begin
+      case Obj.Kind is
+         when Ghdl_Rtik_Signal
+           | Ghdl_Rtik_Port
+           | Ghdl_Rtik_Guard
+           | Ghdl_Rtik_Attribute_Quiet
+           | Ghdl_Rtik_Attribute_Stable
+           | Ghdl_Rtik_Attribute_Transaction =>
+            Sig := To_Ghdl_Rtin_Object_Acc (Obj);
+            Put (stdout, Ctxt);
+            Put (".");
+            Disp_Signal_Name (stdout, Sig);
+            Foreach_Scalar_Signal
+              (Ctxt, Sig.Obj_Type,
+               Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True);
+         when others =>
+            null;
+      end case;
+      return Traverse_Ok;
+   end Disp_Signal;
+
+   function Disp_All_Signals is new Traverse_Blocks (Process => Disp_Signal);
+
+   procedure Disp_All_Signals
+   is
+      Res : Traverse_Result;
+   begin
+      if Boolean'(False) then
+         for I in Sig_Table.First .. Sig_Table.Last loop
+            Disp_Simple_Signal
+              (Sig_Table.Table (I), null, Options.Disp_Sources);
+         end loop;
+      else
+         Res := Disp_All_Signals (Get_Top_Context);
+      end if;
+   end Disp_All_Signals;
+
+
+
+   --  Option disp-signals-map
+
+   Cur_Signals_Map_Ctxt : Rti_Context;
+   Cur_Signals_Map_Obj : Ghdl_Rtin_Object_Acc;
+
+   procedure Disp_Signals_Map_Scalar (Val_Addr : Address;
+                                      Val_Name : Vstring;
+                                      Val_Type : Ghdl_Rti_Access)
+   is
+      pragma Unreferenced (Val_Type);
+
+      function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion
+        (Source => Address, Target => Ghdl_Signal_Ptr);
+
+      S : Ghdl_Signal_Ptr;
+   begin
+      Put (stdout, Cur_Signals_Map_Ctxt);
+      Put (".");
+      Disp_Signal_Name (stdout, Cur_Signals_Map_Obj);
+      Put (stdout, Val_Name);
+      Put (": ");
+      S := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
+      Put (stdout, S.all'Address);
+      Put (" net: ");
+      Put_I32 (stdout, Ghdl_I32 (S.Net));
+      if S.Flags.Has_Active then
+         Put (" +A");
+      end if;
+      New_Line;
+   end Disp_Signals_Map_Scalar;
+
+   procedure Foreach_Disp_Signals_Map_Scalar is new
+     Foreach_Scalar (Process => Disp_Signals_Map_Scalar);
+
+   function Disp_Signals_Map_Signal (Ctxt : Rti_Context;
+                                     Obj : Ghdl_Rti_Access)
+                                    return Traverse_Result
+   is
+      Sig : Ghdl_Rtin_Object_Acc renames Cur_Signals_Map_Obj;
+   begin
+      case Obj.Kind is
+         when Ghdl_Rtik_Signal
+           | Ghdl_Rtik_Port
+           | Ghdl_Rtik_Guard
+           | Ghdl_Rtik_Attribute_Stable
+           | Ghdl_Rtik_Attribute_Quiet
+           | Ghdl_Rtik_Attribute_Transaction =>
+            Cur_Signals_Map_Ctxt := Ctxt;
+            Cur_Signals_Map_Obj := To_Ghdl_Rtin_Object_Acc (Obj);
+            Foreach_Disp_Signals_Map_Scalar
+              (Ctxt, Sig.Obj_Type,
+               Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True);
+         when others =>
+            null;
+      end case;
+      return Traverse_Ok;
+   end Disp_Signals_Map_Signal;
+
+   function Disp_Signals_Map_Blocks is new Traverse_Blocks
+     (Process => Disp_Signals_Map_Signal);
+
+   procedure Disp_Signals_Map
+   is
+      Res : Traverse_Result;
+   begin
+      Res := Disp_Signals_Map_Blocks (Get_Top_Context);
+      Grt.Stdio.fflush (stdout);
+   end Disp_Signals_Map;
+
+   --  Option --disp-signals-table
+   procedure Disp_Mode_Signal (Mode : Mode_Signal_Type)
+   is
+   begin
+      case Mode is
+         when Mode_Signal =>
+            Put ("signal");
+         when Mode_Linkage =>
+            Put ("linkage");
+         when Mode_Buffer =>
+            Put ("buffer");
+         when Mode_Out =>
+            Put ("out");
+         when Mode_Inout =>
+            Put ("inout");
+         when Mode_In =>
+            Put ("in");
+         when Mode_Stable =>
+            Put ("stable");
+         when Mode_Quiet =>
+            Put ("quiet");
+         when Mode_Transaction =>
+            Put ("transaction");
+         when Mode_Delayed =>
+            Put ("delayed");
+         when Mode_Guard =>
+            Put ("guard");
+         when Mode_Conv_In =>
+            Put ("conv_in");
+         when Mode_Conv_Out =>
+            Put ("conv_out");
+         when Mode_End =>
+            Put ("end");
+      end case;
+   end Disp_Mode_Signal;
+
+   procedure Disp_Signals_Table
+   is
+      use Grt.Disp;
+      Sig : Ghdl_Signal_Ptr;
+   begin
+      for I in Sig_Table.First .. Sig_Table.Last loop
+         Sig := Sig_Table.Table (I);
+         Put_Sig_Index (I);
+         Put (": ");
+         Put (stdout, Sig.all'Address);
+         if Sig.Flags.Has_Active then
+            Put (" +A");
+         end if;
+         Put (" net: ");
+         Put_I32 (stdout,  Ghdl_I32 (Sig.Net));
+         Put (" smode: ");
+         Disp_Mode_Signal (Sig.S.Mode_Sig);
+         Put (" #prt: ");
+         Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports));
+         if Sig.S.Mode_Sig in Mode_Signal_User then
+            Put (" #drv: ");
+            Put_I32 (stdout, Ghdl_I32 (Sig.S.Nbr_Drivers));
+            if Sig.S.Effective /= null then
+               Put (" eff: ");
+               Put (stdout, Sig.S.Effective.all'Address);
+            end if;
+            if Sig.S.Resolv /= null then
+               Put (" resolved");
+            end if;
+         end if;
+         if Boolean'(False) then
+            Put (" link: ");
+            Put (stdout, Sig.Link.all'Address);
+         end if;
+         New_Line;
+         if Sig.Nbr_Ports /= 0 then
+            for J in 1 .. Sig.Nbr_Ports loop
+               Put ("  ");
+               Put (stdout, Sig.Ports (J - 1).all'Address);
+            end loop;
+            New_Line;
+         end if;
+      end loop;
+      Grt.Stdio.fflush (stdout);
+   end Disp_Signals_Table;
+
+   procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr)
+   is
+   begin
+      Disp_Simple_Signal (Sig, null, True);
+   end Disp_A_Signal;
+
+   procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr)
+   is
+      Found : Boolean := False;
+      Cur_Ctxt : Rti_Context;
+      Cur_Sig : Ghdl_Rtin_Object_Acc;
+
+      procedure Process_Scalar  (Val_Addr : Address;
+                                 Val_Name : Vstring;
+                                 Val_Type : Ghdl_Rti_Access)
+      is
+         pragma Unreferenced (Val_Type);
+         Sig1 : Ghdl_Signal_Ptr;
+      begin
+         --  Read the signal.
+         Sig1 := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
+         if Sig1 = Sig and not Found then
+            Put (Stream, Cur_Ctxt);
+            Put (Stream, ".");
+            Disp_Signal_Name (Stream, Cur_Sig);
+            Put (Stream, Val_Name);
+            Found := True;
+         end if;
+      end Process_Scalar;
+
+      procedure Foreach_Scalar is new Grt.Rtis_Utils.Foreach_Scalar
+        (Process_Scalar);
+
+      function Process_Block (Ctxt : Rti_Context;
+                              Obj : Ghdl_Rti_Access)
+                             return Traverse_Result
+      is
+      begin
+         case Obj.Kind is
+            when Ghdl_Rtik_Signal
+              | Ghdl_Rtik_Port
+              | Ghdl_Rtik_Guard
+              | Ghdl_Rtik_Attribute_Stable
+              | Ghdl_Rtik_Attribute_Quiet
+              | Ghdl_Rtik_Attribute_Transaction =>
+               Cur_Ctxt := Ctxt;
+               Cur_Sig := To_Ghdl_Rtin_Object_Acc (Obj);
+               Foreach_Scalar
+                 (Ctxt, Cur_Sig.Obj_Type,
+                  Loc_To_Addr (Cur_Sig.Common.Depth, Cur_Sig.Loc, Ctxt), True);
+               if Found then
+                  return Traverse_Stop;
+               end if;
+            when others =>
+               null;
+         end case;
+         return Traverse_Ok;
+      end Process_Block;
+
+      function Foreach_Block is new Grt.Rtis_Utils.Traverse_Blocks
+        (Process_Block);
+
+      Res_Status : Traverse_Result;
+   begin
+      Res_Status := Foreach_Block (Get_Top_Context);
+      if not Found then
+         Put (Stream, "(unknown signal)");
+      end if;
+   end Put_Signal_Name;
+
+end Grt.Disp_Signals;