vhdl: supports VHPIDIRECT in mcode backend.

src: add hash.ad[sb], interning.ad[sb]
Automatically link with vhpidirect libraries.

7 files changed, 144 insertions, 89 deletions

diff --git a/src/vhdl/translate/ortho_front.adb b/src/vhdl/translate/ortho_front.adb
index 041eae45e..208348ef4 100644
--- a/src/vhdl/translate/ortho_front.adb
+++ b/src/vhdl/translate/ortho_front.adb
@@ -15,8 +15,13 @@
 --  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;
+with Interfaces.C_Streams;
+
 with Types; use Types;
 with Name_Table;
+with Hash;
+with Interning;
 with Iirs; use Iirs;
 with Libraries;
 with Iirs_Utils; use Iirs_Utils;
@@ -397,6 +402,117 @@ package body Ortho_Front is
       Libraries.Save_Work_Library;
    end Do_Compile;
 
+   --  Table of libraries gathered from vhpidirect.
+   function Shlib_Build (Name : String) return String_Acc is
+   begin
+      return new String'(Name);
+   end Shlib_Build;
+
+   function Shlib_Equal (Obj : String_Acc; Param : String) return Boolean is
+   begin
+      return Obj.all = Param;
+   end Shlib_Equal;
+
+   package Shlib_Interning is new Interning
+     (Params_Type => String,
+      Object_Type => String_Acc,
+      Hash => Hash.String_Hash,
+      Build => Shlib_Build,
+      Equal => Shlib_Equal);
+
+   procedure Sem_Foreign_Hook
+     (Decl : Iir; Info : Translation.Foreign_Info_Type)
+   is
+      pragma Unreferenced (Decl);
+      use Translation;
+   begin
+      case Info.Kind is
+         when Foreign_Vhpidirect =>
+            declare
+               Lib : constant String :=
+                 Info.Lib_Name (1 .. Info.Lib_Len);
+               Shlib : String_Acc;
+               pragma Unreferenced (Shlib);
+            begin
+               if Info.Lib_Len /= 0 and then Lib /= "null" then
+                  Shlib := Shlib_Interning.Get (Lib);
+               end if;
+            end;
+         when Foreign_Intrinsic =>
+            null;
+         when Foreign_Unknown =>
+            null;
+      end case;
+   end Sem_Foreign_Hook;
+
+   --  Write to file FILELIST all the files that are needed to link the design.
+   procedure Write_File_List (Filelist : String)
+   is
+      use Interfaces.C_Streams;
+      use System;
+      use Configuration;
+      use Name_Table;
+
+      Nul : constant Character := Character'Val (0);
+      Fname : String := Filelist & Nul;
+      Mode : constant String := "wt" & Nul;
+      F : FILEs;
+      R : int;
+      S : size_t;
+      pragma Unreferenced (R, S); -- FIXME
+      Id : Name_Id;
+      Lib : Iir_Library_Declaration;
+      File : Iir_Design_File;
+      Unit : Iir_Design_Unit;
+   begin
+      F := fopen (Fname'Address, Mode'Address);
+      if F = NULL_Stream then
+         Error_Msg_Elab ("cannot open " & Filelist);
+         return;
+      end if;
+
+      --  Clear elab flags on design files.
+      for I in Design_Units.First .. Design_Units.Last loop
+         Unit := Design_Units.Table (I);
+         File := Get_Design_File (Unit);
+         Set_Elab_Flag (File, False);
+      end loop;
+
+      for J in Design_Units.First .. Design_Units.Last loop
+         Unit := Design_Units.Table (J);
+         File := Get_Design_File (Unit);
+         if not Get_Elab_Flag (File) then
+            Set_Elab_Flag (File, True);
+
+            --  Write '>LIBRARY_DIRECTORY'.
+            Lib := Get_Library (File);
+            R := fputc (Character'Pos ('>'), F);
+            Id := Get_Library_Directory (Lib);
+            S := fwrite (Get_Address (Id),
+                         size_t (Get_Name_Length (Id)), 1, F);
+            R := fputc (10, F);
+
+            --  Write 'FILENAME'.
+            Id := Get_Design_File_Filename (File);
+            S := fwrite (Get_Address (Id),
+                         size_t (Get_Name_Length (Id)), 1, F);
+            R := fputc (10, F);
+         end if;
+      end loop;
+
+      for I in Shlib_Interning.First_Index .. Shlib_Interning.Last_Index loop
+         declare
+            Str : constant String_Acc := Shlib_Interning.Get_By_Index (I);
+         begin
+            R := fputc (Character'Pos ('+'), F);
+            S := fwrite (Str.all'Address, size_t (Str'Length), 1, F);
+            R := fputc (10, F);
+         end;
+      end loop;
+
+      R := fclose (F);
+   end Write_File_List;
+
    Nbr_Parse : Natural := 0;
 
    function Parse (Filename : String_Acc) return Boolean
@@ -429,13 +545,21 @@ package body Ortho_Front is
                Error_Msg_Option ("missing -l for --elab");
                raise Option_Error;
             end if;
+
+            --  Be sure to collect libraries used for vhpidirect.
+            Trans_Be.Sem_Foreign_Hook := Sem_Foreign_Hook'Access;
+            Shlib_Interning.Init;
+
             Config := Configuration.Configure
               (Elab_Entity.all, Elab_Architecture.all);
             if Errorout.Nbr_Errors > 0 then
                --  This may happen (bad entity for example).
                raise Compilation_Error;
             end if;
-            Translation.Elaborate (Config, Elab_Filelist.all, False);
+
+            Translation.Elaborate (Config, False);
+
+            Write_File_List (Elab_Filelist.all);
 
             if Errorout.Nbr_Errors > 0 then
                --  This may happen (bad entity for example).
@@ -482,7 +606,7 @@ package body Ortho_Front is
             Flags.Flag_Only_Elab_Warnings := False;
             Config := Configuration.Configure
               (Elab_Entity.all, Elab_Architecture.all);
-            Translation.Elaborate (Config, "", True);
+            Translation.Elaborate (Config, True);
 
             if Errorout.Nbr_Errors > 0 then
                --  This may happen (bad entity for example).
diff --git a/src/vhdl/translate/trans-chap12.adb b/src/vhdl/translate/trans-chap12.adb
index 387c80863..1e39d3456 100644
--- a/src/vhdl/translate/trans-chap12.adb
+++ b/src/vhdl/translate/trans-chap12.adb
@@ -16,13 +16,10 @@
 --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 --  02111-1307, USA.
 
-with System;
 with Configuration;
-with Interfaces.C_Streams;
 with Errorout; use Errorout;
 with Std_Package; use Std_Package;
 with Iirs_Utils; use Iirs_Utils;
-with Name_Table;
 with Libraries;
 with Flags;
 with Sem;
@@ -528,72 +525,10 @@ package body Trans.Chap12 is
       end loop;
    end Gen_Stubs;
 
-   --  Write to file FILELIST all the files that are needed to link the design.
-   procedure Write_File_List (Filelist : String)
-   is
-      use Interfaces.C_Streams;
-      use System;
-      use Configuration;
-      use Name_Table;
-
-      Nul : constant Character := Character'Val (0);
-      Fname : String := Filelist & Nul;
-      Mode : constant String := "wt" & Nul;
-      F : FILEs;
-      R : int;
-      S : size_t;
-      pragma Unreferenced (R, S); -- FIXME
-      Id : Name_Id;
-      Lib : Iir_Library_Declaration;
-      File : Iir_Design_File;
-      Unit : Iir_Design_Unit;
-   begin
-      F := fopen (Fname'Address, Mode'Address);
-      if F = NULL_Stream then
-         Error_Msg_Elab ("cannot open " & Filelist);
-         return;
-      end if;
-
-      --  Clear elab flags on design files.
-      for I in Design_Units.First .. Design_Units.Last loop
-         Unit := Design_Units.Table (I);
-         File := Get_Design_File (Unit);
-         Set_Elab_Flag (File, False);
-      end loop;
-
-      for J in Design_Units.First .. Design_Units.Last loop
-         Unit := Design_Units.Table (J);
-         File := Get_Design_File (Unit);
-         if not Get_Elab_Flag (File) then
-            Set_Elab_Flag (File, True);
-
-            --  Write '>LIBRARY_DIRECTORY'.
-            Lib := Get_Library (File);
-            R := fputc (Character'Pos ('>'), F);
-            Id := Get_Library_Directory (Lib);
-            S := fwrite (Get_Address (Id),
-                         size_t (Get_Name_Length (Id)), 1, F);
-            R := fputc (10, F);
-
-            --  Write 'FILENAME'.
-            Id := Get_Design_File_Filename (File);
-            S := fwrite (Get_Address (Id),
-                         size_t (Get_Name_Length (Id)), 1, F);
-            R := fputc (10, F);
-         end if;
-      end loop;
-
-      R := fclose (F);
-   end Write_File_List;
-
-   procedure Elaborate (Config : Iir_Design_Unit;
-                        Filelist : String;
-                        Whole : Boolean)
+   procedure Elaborate (Config : Iir_Design_Unit; Whole : Boolean)
    is
       use Configuration;
 
-      Has_Filelist : constant Boolean := Filelist /= "";
-
       Unit : Iir_Design_Unit;
       Lib_Unit : Iir;
       Config_Lib : Iir_Configuration_Declaration;
@@ -751,11 +686,6 @@ package body Trans.Chap12 is
          Gen_Stubs;
       end if;
 
-      --  Write the file containing the list of object files.
-      if Has_Filelist then
-         Write_File_List (Filelist);
-      end if;
-
       --  Disp list of files needed.
       if Flags.Verbose then
          Report_Msg (Msgid_Note, Elaboration, No_Location,
diff --git a/src/vhdl/translate/trans-chap12.ads b/src/vhdl/translate/trans-chap12.ads
index a0db62399..248b7851d 100644
--- a/src/vhdl/translate/trans-chap12.ads
+++ b/src/vhdl/translate/trans-chap12.ads
@@ -23,11 +23,6 @@ package Trans.Chap12 is
    --  Generate ortho code to elaborate declaration of the top unit.
    procedure Call_Elab_Decls (Arch : Iir; Arch_Instance : O_Enode);
 
-   --  Write to file FILELIST all the files that are needed to link the design.
-   procedure Write_File_List (Filelist : String);
-
    --  Generate elaboration code for CONFIG.
-   procedure Elaborate (Config : Iir_Design_Unit;
-                        Filelist : String;
-                        Whole : Boolean);
+   procedure Elaborate (Config : Iir_Design_Unit; Whole : Boolean);
 end Trans.Chap12;
diff --git a/src/vhdl/translate/trans_be.adb b/src/vhdl/translate/trans_be.adb
index 699c1e55e..e3f8e20da 100644
--- a/src/vhdl/translate/trans_be.adb
+++ b/src/vhdl/translate/trans_be.adb
@@ -15,8 +15,6 @@
 --  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 Iirs; use Iirs;
-with Translation;
 with Errorout; use Errorout;
 with Ada.Text_IO;
 with Back_End;
@@ -26,7 +24,6 @@ package body Trans_Be is
    is
       use Translation;
       Fi : Foreign_Info_Type;
-      pragma Unreferenced (Fi);
    begin
       case Get_Kind (Decl) is
          when Iir_Kind_Architecture_Body =>
@@ -39,6 +36,10 @@ package body Trans_Be is
       end case;
       --  Let it generate error messages.
       Fi := Translate_Foreign_Id (Decl);
+
+      if Sem_Foreign_Hook /= null then
+         Sem_Foreign_Hook.all (Decl, Fi);
+      end if;
    end Sem_Foreign;
 
    function Parse_Option (Opt : String) return Boolean is
diff --git a/src/vhdl/translate/trans_be.ads b/src/vhdl/translate/trans_be.ads
index 9ff06031b..95cf04c1a 100644
--- a/src/vhdl/translate/trans_be.ads
+++ b/src/vhdl/translate/trans_be.ads
@@ -15,7 +15,15 @@
 --  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 Iirs; use Iirs;
+with Translation;
+
 package Trans_Be is
+   type Sem_Foreign_Hook_Type is access
+     procedure (Decl : Iir; Info : Translation.Foreign_Info_Type);
+
+   --  Hook called by Sem_Foreign.
+   Sem_Foreign_Hook : Sem_Foreign_Hook_Type := null;
+
    procedure Register_Translation_Back_End;
 end Trans_Be;
-
diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb
index fd68e2f84..9dab1243b 100644
--- a/src/vhdl/translate/translation.adb
+++ b/src/vhdl/translate/translation.adb
@@ -2130,8 +2130,7 @@ package body Translation is
       Free_Old_Temp;
    end Finalize;
 
-   procedure Elaborate (Config : Iir;
-                        Filelist : String;
-                        Whole : Boolean) renames Trans.Chap12.Elaborate;
+   procedure Elaborate (Config : Iir; Whole : Boolean)
+     renames Trans.Chap12.Elaborate;
 
 end Translation;
diff --git a/src/vhdl/translate/translation.ads b/src/vhdl/translate/translation.ads
index ffaabd3bf..ca8877ad7 100644
--- a/src/vhdl/translate/translation.ads
+++ b/src/vhdl/translate/translation.ads
@@ -42,9 +42,7 @@ package Translation is
 
    --  Generate elaboration code for CONFIG.  Also use units from Configure
    --  package.
-   procedure Elaborate (Config : Iir;
-                        Filelist : String;
-                        Whole : Boolean);
+   procedure Elaborate (Config : Iir; Whole : Boolean);
 
    --  If set, generate Run-Time Information nodes.
    Flag_Rti : Boolean := True;