fix VHDL 08 preprocessor block comments in libraries to start in column 1

3 files changed, 136 insertions, 16 deletions

diff --git a/libraries/std/textio.vhdl b/libraries/std/textio.vhdl
index 25d90ec04..fe69d2d88 100644
--- a/libraries/std/textio.vhdl
+++ b/libraries/std/textio.vhdl
@@ -35,11 +35,11 @@ package Textio is
 
   -- standard text files
 
-  --START-V08
+--START-V08
   function Justify (Value: String;
                     Justified : Side := Right;
                     Field: Width := 0 ) return String;
-  --END-V08
+--END-V08
 
   file input:  text is in "STD_INPUT";  --V87
   file output: text is out "STD_OUTPUT";  --V87
@@ -95,7 +95,7 @@ package Textio is
   procedure read (l: inout line; value: out time; good: out boolean);
   procedure read (l: inout line; value: out time);
 
-  --START-V08
+--START-V08
   procedure Sread (L : inout Line; Value : out String; Strlen : out Natural);
 
   alias STRING_READ is SREAD [LINE, STRING, NATURAL];
@@ -115,16 +115,16 @@ package Textio is
 
   alias HEX_READ is HREAD [LINE, BIT_VECTOR, BOOLEAN];
   alias HEX_READ is HREAD [LINE, BIT_VECTOR];
-  --END-V08
+--END-V08
 
 -- output routines for standard types
 
   procedure writeline (variable f: out text; l: inout line); --V87
   procedure writeline (file f: text; l: inout line); --V93
 
-  --START-V08
+--START-V08
   procedure Tee (file f : Text; L : inout LINE);
-  --END-V08
+--END-V08
 
   --  This implementation accept any value for all the types.
   procedure write
@@ -159,7 +159,7 @@ package Textio is
     (l: inout line; value : in time;
     justified: in side := right; field: in width := 0; unit : in TIME := ns);
 
-  --START-V08
+--START-V08
   alias Swrite is write [Line, String, Side, Width];
   alias String_Write is Write [Line, String, Side, Width];
 
diff --git a/libraries/std/textio_body.vhdl b/libraries/std/textio_body.vhdl
index 5d148cef4..bb4ea8c8a 100644
--- a/libraries/std/textio_body.vhdl
+++ b/libraries/std/textio_body.vhdl
@@ -17,7 +17,7 @@
 --  02111-1307, USA.
 
 package body textio is
-  --START-V08
+--START-V08
   --  LRM08 16.4
   --  The JUSTIFY operation formats a string value within a field that is at
   --  least at long as required to contain the value.  Parameter FIELD
@@ -49,7 +49,7 @@ package body textio is
       end case;
     end if;
   end Justify;
-  --END-V08
+--END-V08
 
   -- output routines for standard types
 
@@ -102,7 +102,7 @@ package body textio is
     end if;
   end writeline;
 
-  --START-V08
+--START-V08
   procedure Tee (file f : Text; L : inout LINE) is
   begin
     if l = null then
@@ -122,7 +122,7 @@ package body textio is
       l := new string'("");
     end if;
   end Tee;
-  --END-V08
+--END-V08
   
   procedure write
     (l: inout line; value: in string;
@@ -482,7 +482,7 @@ package body textio is
     write (l, str (1 to pos - 1), justified, field);
   end write;
 
-  --START-V08
+--START-V08
   procedure Owrite (L : inout line; value : in Bit_Vector;
                     Justified : in Side := Right; Field : in Width := 0) is
   begin
@@ -1410,7 +1410,7 @@ package body textio is
       severity failure;
   end read;
 
-  --START-V08
+--START-V08
   procedure Sread (L : inout Line; Value : out String; Strlen : out Natural)
   is
     constant maxlen : natural := Value'Length;
@@ -1682,5 +1682,5 @@ package body textio is
       report "hexa bit_vector read failure"
       severity failure;
   end Hread;
-  --END-V08
+--END-V08
 end textio;
diff --git a/src/grt/grt-fst.adb b/src/grt/grt-fst.adb
index e6d9e6721..a81022be9 100644
--- a/src/grt/grt-fst.adb
+++ b/src/grt/grt-fst.adb
@@ -39,9 +39,16 @@ with Grt.Hooks; use Grt.Hooks;
 with Grt.Rtis; use Grt.Rtis;
 with Grt.Rtis_Types; use Grt.Rtis_Types;
 with Grt.Vstrings;
+with Ada.Unchecked_Deallocation;
 pragma Elaborate_All (Grt.Table);
 
 package body Grt.Fst is
+   --  FST format has a mechanism to declare signal aliases (if two signals
+   --  in the hierarchy are the same).  Enabling this reduce the number of
+   --  signals dumped, but weirdly it makes the FST file slightly bigger.
+   Flag_Aliases : constant Boolean := True;
+
+   --  Global FST context.  Set to non-NULL iff dumping signals to an FST file.
    Context : fstContext := Null_fstContext;
 
    --  Index type of the table of vcd variables to dump.
@@ -115,6 +122,80 @@ package body Grt.Fst is
       Put_Line ("Fst.Avhpi_Error!");
    end Avhpi_Error;
 
+   function Equal (Left, Right : Verilog_Wire_Info) return Boolean
+   is
+      Len : Ghdl_Index_Type;
+   begin
+      if Left.Kind /= Right.Kind
+        or else Left.Val /= Right.Val
+      then
+         return False;
+      end if;
+
+      --  Get length.
+      Len := Get_Wire_Length (Left);
+      if Len /= Get_Wire_Length (Right) then
+         return False;
+      end if;
+
+      --  Compare signals.
+      for I in 1 .. Len loop
+         if Left.Sigs (I - 1) /= Right.Sigs (I - 1) then
+            return False;
+         end if;
+      end loop;
+      return True;
+   end Equal;
+
+   function Hash (El : Verilog_Wire_Info) return Ghdl_Index_Type
+   is
+      Len : constant Ghdl_Index_Type := Get_Wire_Length (El);
+      Res : Ghdl_Index_Type;
+      Iaddr : Integer_Address;
+   begin
+      Res := Vcd_Var_Kind'Pos (El.Kind) * 2 + Vcd_Value_Kind'Pos (El.Val);
+      Res := Res + Len * 29;
+      for I in 1 .. Len loop
+         Iaddr := To_Integer (El.Sigs (I - 1).all'Address);
+         Res := Res +
+           Ghdl_Index_Type (Iaddr mod Integer_Address (Ghdl_Index_Type'Last));
+      end loop;
+      return Res;
+   end Hash;
+
+   --  Very simple hash table to detect aliases.
+   type Bucket_Type;
+   type Bucket_Acc is access Bucket_Type;
+
+   type Bucket_Type is record
+      El : Fst_Index_Type;
+      Next : Bucket_Acc;
+   end record;
+
+   type Hash_Table is array (Ghdl_Index_Type range <>) of Bucket_Acc;
+   type Hash_Table_Acc is access Hash_Table;
+
+   Hash_Tab : Hash_Table_Acc;
+
+   procedure Free_Hash_Tab
+   is
+      procedure Free_Hash_Table is new
+        Ada.Unchecked_Deallocation (Hash_Table, Hash_Table_Acc);
+      procedure Free_Bucket_Type is new
+        Ada.Unchecked_Deallocation (Bucket_Type, Bucket_Acc);
+      Ent, Nent : Bucket_Acc;
+   begin
+      for I in Hash_Tab'Range loop
+         Ent := Hash_Tab (I);
+         while Ent /= null loop
+            Nent := Ent.Next;
+            Free_Bucket_Type (Ent);
+            Ent := Nent;
+         end loop;
+      end loop;
+      Free_Hash_Table (Hash_Tab);
+   end Free_Hash_Tab;
+
    procedure Fst_Add_Signal (Sig : VhpiHandleT)
    is
       Vcd_El : Verilog_Wire_Info;
@@ -125,6 +206,8 @@ package body Grt.Fst is
       Name : String (1 .. 128);
       Name_Len : Natural;
       Hand : fstHandle;
+      Alias : fstHandle;
+      H : Ghdl_Index_Type;
    begin
       Get_Verilog_Wire (Sig, Vcd_El);
 
@@ -181,6 +264,25 @@ package body Grt.Fst is
          Dir := FST_VD_IMPLICIT;
       end if;
 
+      --  Try to find an alias.
+      Alias := Null_fstHandle;
+      if Flag_Aliases then
+         declare
+            Ent : Bucket_Acc;
+         begin
+            H := Hash (Vcd_El) mod (Hash_Tab'Last + 1);
+            Ent := Hash_Tab (H);
+            while Ent /= null loop
+               if Equal (Fst_Table.Table (Ent.El).Wire, Vcd_El) then
+                  Alias := Fst_Table.Table (Ent.El).Hand;
+                  exit;
+               else
+                  Ent := Ent.Next;
+               end if;
+            end loop;
+         end;
+      end if;
+
       Vhpi_Get_Str (VhpiNameP, Sig, Name, Name_Len);
       if Name_Len >= Name'Length
         or else Vcd_El.Irange /= null
@@ -217,16 +319,25 @@ package body Grt.Fst is
 
             Hand := fstWriterCreateVar2
               (Context, Vt, Dir, Len, To_Ghdl_C_String (Name2'Address),
-               Null_fstHandle, null, FST_SVT_VHDL_SIGNAL, Sdt);
+               Alias, null, FST_SVT_VHDL_SIGNAL, Sdt);
          end;
       else
          Name (Name_Len) := NUL;
          Hand := fstWriterCreateVar2
            (Context, Vt, Dir, Len, To_Ghdl_C_String (Name'Address),
-            Null_fstHandle, null, FST_SVT_VHDL_SIGNAL, Sdt);
+            Alias, null, FST_SVT_VHDL_SIGNAL, Sdt);
+      end if;
+
+      if Flag_Aliases and then Interfaces.C."/=" (Alias, Null_fstHandle) then
+         return;
       end if;
 
       Fst_Table.Append (Fst_Sig_Info'(Wire => Vcd_El, Hand => Hand));
+
+      if Flag_Aliases then
+         Hash_Tab (H) := new Bucket_Type'(El => Fst_Table.Last,
+                                          Next => Hash_Tab (H));
+      end if;
    end Fst_Add_Signal;
 
    procedure Fst_Put_Hierarchy (Inst : VhpiHandleT);
@@ -417,10 +528,19 @@ package body Grt.Fst is
       --  Be sure the RTI of std_ulogic is set.
       Search_Types_RTI;
 
+      if Flag_Aliases then
+         Hash_Tab :=
+           new Hash_Table (0 .. Ghdl_Index_Type (Sig_Table.Last / 17));
+      end if;
+
       --  Put hierarchy.
       Get_Root_Inst (Root);
       Fst_Put_Hierarchy (Root);
 
+      if Flag_Aliases then
+         Free_Hash_Tab;
+      end if;
+
       Register_Cycle_Hook (Fst_Cycle'Access);
    end Fst_Start;