diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ghdldrv/ghdldrv.adb | 7 | ||||
| -rw-r--r-- | src/ghdldrv/ghdlrun.adb | 75 | ||||
| -rw-r--r-- | src/hash.adb | 30 | ||||
| -rw-r--r-- | src/hash.ads | 26 | ||||
| -rw-r--r-- | src/interning.adb | 140 | ||||
| -rw-r--r-- | src/interning.ads | 59 | ||||
| -rw-r--r-- | src/types.ads | 2 | ||||
| -rw-r--r-- | src/vhdl/translate/ortho_front.adb | 128 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap12.adb | 72 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap12.ads | 7 | ||||
| -rw-r--r-- | src/vhdl/translate/trans_be.adb | 7 | ||||
| -rw-r--r-- | src/vhdl/translate/trans_be.ads | 10 | ||||
| -rw-r--r-- | src/vhdl/translate/translation.adb | 5 | ||||
| -rw-r--r-- | src/vhdl/translate/translation.ads | 4 |
14 files changed, 473 insertions, 99 deletions
diff --git a/src/ghdldrv/ghdldrv.adb b/src/ghdldrv/ghdldrv.adb index e77bfb8f4..cdec0eca6 100644 --- a/src/ghdldrv/ghdldrv.adb +++ b/src/ghdldrv/ghdldrv.adb @@ -315,6 +315,7 @@ package body Ghdldrv is Free (Obj_File); end Do_Compile; + -- Table of files to be linked. package Filelist is new Tables (Table_Component_Type => String_Access, Table_Index_Type => Natural, @@ -383,6 +384,9 @@ package body Ghdldrv is if Line (1) = '>' then Dir_Len := L - 1; Dir (1 .. Dir_Len) := Line (2 .. L); + elsif Line (1) = '+' then + File := new String'(Line (2 .. L)); + Filelist.Append (File); else if To_Obj then File := new String'(Dir (1 .. Dir_Len) @@ -392,8 +396,7 @@ package body Ghdldrv is File := new String'(Substitute (Line (1 .. L))); end if; - Filelist.Increment_Last; - Filelist.Table (Filelist.Last) := File; + Filelist.Append (File); Dir_Len := 0; end if; diff --git a/src/ghdldrv/ghdlrun.adb b/src/ghdldrv/ghdlrun.adb index 3501bb692..fbe10c5d3 100644 --- a/src/ghdldrv/ghdlrun.adb +++ b/src/ghdldrv/ghdlrun.adb @@ -44,12 +44,15 @@ with Ieee.Std_Logic_1164; with Lists; with Str_Table; +with Hash; +with Interning; with Nodes; with Files_Map; with Name_Table; with Grt.Main; with Grt.Modules; +with Grt.Dynload; use Grt.Dynload; with Grt.Lib; with Grt.Processes; with Grt.Rtis; @@ -80,6 +83,36 @@ package body Ghdlrun is -- Default elaboration mode is dynamic. Elab_Mode : constant Elab_Mode_Type := Elab_Dynamic; + type Shlib_Object_Type is record + Name : String_Access; + Handler : Address; + end record; + + function Shlib_Build (Name : String) return Shlib_Object_Type + is + Name_Acc : constant String_Access := new String'(Name); + C_Name : constant String := Name & Nul; + Handler : Address; + begin + Handler := + Grt_Dynload_Open (Grt.Types.To_Ghdl_C_String (C_Name'Address)); + return (Name => Name_Acc, + Handler => Handler); + end Shlib_Build; + + function Shlib_Equal (Obj : Shlib_Object_Type; Param : String) + return Boolean is + begin + return Obj.Name.all = Param; + end Shlib_Equal; + + package Shlib_Interning is new Interning + (Params_Type => String, + Object_Type => Shlib_Object_Type, + Hash => Hash.String_Hash, + Build => Shlib_Build, + Equal => Shlib_Equal); + procedure Foreign_Hook (Decl : Iir; Info : Translation.Foreign_Info_Type; Ortho : O_Dnode); @@ -103,6 +136,7 @@ package body Ghdlrun is end if; Translation.Foreign_Hook := Foreign_Hook'Access; + Shlib_Interning.Init; -- FIXME: add a flag to force unnesting. -- Translation.Flag_Unnest_Subprograms := True; @@ -174,7 +208,7 @@ package body Ghdlrun is when Elab_Static => raise Program_Error; when Elab_Dynamic => - Translation.Elaborate (Config, "", True); + Translation.Elaborate (Config, True); end case; if Errorout.Nbr_Errors > 0 then @@ -241,14 +275,43 @@ package body Ghdlrun is declare Name : constant String := Info.Subprg_Name (1 .. Info.Subprg_Len); + Lib : constant String := + Info.Lib_Name (1 .. Info.Lib_Len); + Shlib : Shlib_Object_Type; begin - Res := Foreigns.Find_Foreign (Name); - if Res /= Null_Address then - Def (Ortho, Res); + if Info.Lib_Len = 0 + or else Lib = "null" + then + Res := Foreigns.Find_Foreign (Name); + if Res = Null_Address then + Error_Msg_Sem + (+Decl, "unknown foreign VHPIDIRECT '" & Name & "'"); + return; + end if; else - Error_Msg_Sem - (+Decl, "unknown foreign VHPIDIRECT '" & Name & "'"); + Shlib := Shlib_Interning.Get (Lib); + if Shlib.Handler = Null_Address then + Error_Msg_Sem + (+Decl, "cannot load VHPIDIRECT shared library '" & + Lib & "'"); + return; + end if; + + declare + C_Name : constant String := Name & Nul; + begin + Res := Grt_Dynload_Symbol + (Shlib.Handler, + Grt.Types.To_Ghdl_C_String (C_Name'Address)); + end; + if Res = Null_Address then + Error_Msg_Sem + (+Decl, "cannot resolve VHPIDIRECT symbol '" + & Name & "'"); + return; + end if; end if; + Def (Ortho, Res); end; when Foreign_Intrinsic => diff --git a/src/hash.adb b/src/hash.adb new file mode 100644 index 000000000..194a378dd --- /dev/null +++ b/src/hash.adb @@ -0,0 +1,30 @@ +-- Hash. +-- Copyright (C) 2019 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package body Hash is + function String_Hash (Key : String) return Hash_Value_Type + is + Res : Hash_Value_Type; + begin + Res := 0; + for I in Key'Range loop + Res := Res * 5 + Character'Pos (Key (I)); + end loop; + return Res; + end String_Hash; +end Hash; diff --git a/src/hash.ads b/src/hash.ads new file mode 100644 index 000000000..839099dd2 --- /dev/null +++ b/src/hash.ads @@ -0,0 +1,26 @@ +-- Hash. +-- Copyright (C) 2019 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; + +package Hash is + type Hash_Value_Type is new Uns32; + + -- A simple hash function for strings. + function String_Hash (Key : String) return Hash_Value_Type; +end Hash; diff --git a/src/interning.adb b/src/interning.adb new file mode 100644 index 000000000..66aedf903 --- /dev/null +++ b/src/interning.adb @@ -0,0 +1,140 @@ +-- Type interning - set of unique objects. +-- Copyright (C) 2019 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Unchecked_Deallocation; +with Dyn_Tables; + +package body Interning is + type Element_Wrapper is record + Hash : Hash_Value_Type; + Next : Index_Type; + Obj : Object_Type; + end record; + + package Wrapper_Tables is new Dyn_Tables + (Table_Index_Type => Index_Type, + Table_Component_Type => Element_Wrapper, + Table_Low_Bound => No_Index + 1, + Table_Initial => 128); + + type Hash_Array is array (Hash_Value_Type range <>) of Index_Type; + type Hash_Array_Acc is access Hash_Array; + + Initial_Size : constant Hash_Value_Type := 1024; + + Size : Hash_Value_Type; + Hash_Table : Hash_Array_Acc; + Els : Wrapper_Tables.Instance; + + procedure Deallocate is new Ada.Unchecked_Deallocation + (Hash_Array, Hash_Array_Acc); + + procedure Init is + begin + Size := Initial_Size; + Hash_Table := new Hash_Array'(0 .. Initial_Size - 1 => No_Index); + Wrapper_Tables.Init (Els); + pragma Assert (Wrapper_Tables.Last (Els) = No_Index); + end Init; + + -- Expand the hash table (double the size). + procedure Expand + is + Old_Hash_Table : Hash_Array_Acc; + Idx : Index_Type; + begin + Old_Hash_Table := Hash_Table; + Size := Size * 2; + Hash_Table := new Hash_Array'(0 .. Size - 1 => No_Index); + + -- Rehash. + for I in Old_Hash_Table'Range loop + Idx := Old_Hash_Table (I); + while Idx /= No_Index loop + -- Note: collisions are put in reverse order. + declare + Ent : Element_Wrapper renames Els.Table (Idx); + Hash_Index : constant Hash_Value_Type := + Ent.Hash and (Size - 1); + Next_Idx : constant Index_Type := Ent.Next; + begin + Ent.Next := Hash_Table (Hash_Index); + Hash_Table (Hash_Index) := Idx; + Idx := Next_Idx; + end; + end loop; + end loop; + + Deallocate (Old_Hash_Table); + end Expand; + + function Get (Params : Params_Type) return Object_Type + is + Hash_Value : Hash_Value_Type; + Hash_Index : Hash_Value_Type; + Idx : Index_Type; + Res : Object_Type; + begin + -- Check if the package was initialized. + pragma Assert (Hash_Table /= null); + + Hash_Value := Hash (Params); + Hash_Index := Hash_Value and (Size - 1); + + Idx := Hash_Table (Hash_Index); + while Idx /= No_Index loop + declare + E : Element_Wrapper renames Els.Table (Idx); + begin + if E.Hash = Hash_Value and then Equal (E.Obj, Params) then + return E.Obj; + end if; + Idx := E.Next; + end; + end loop; + + -- Maybe expand the table. + if Hash_Value_Type (Wrapper_Tables.Last (Els)) > 2 * Size then + Expand; + + -- Recompute hash index. + Hash_Index := Hash_Value and (Size - 1); + end if; + + Res := Build (Params); + + -- Insert. + Wrapper_Tables.Append (Els, + (Hash => Hash_Value, + Next => Hash_Table (Hash_Index), + Obj => Res)); + Hash_Table (Hash_Index) := Wrapper_Tables.Last (Els); + return Res; + end Get; + + function Last_Index return Index_Type is + begin + return Wrapper_Tables.Last (Els); + end Last_Index; + + function Get_By_Index (Index : Index_Type) return Object_Type is + begin + pragma Assert (Index <= Wrapper_Tables.Last (Els)); + return Els.Table (Index).Obj; + end Get_By_Index; +end Interning; diff --git a/src/interning.ads b/src/interning.ads new file mode 100644 index 000000000..70573022e --- /dev/null +++ b/src/interning.ads @@ -0,0 +1,59 @@ +-- Type interning - set of unique objects. +-- Copyright (C) 2019 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Hash; use Hash; + +-- This generic package provides a factory to build unique objects. +-- Get will return an existing object or create a new one. +generic + -- Parameters of the object to be created. + type Params_Type (<>) is private; + + -- Object to be built and stored. + type Object_Type is private; + + -- Reduce PARAMS to a small value. + -- The required property is: Hash(P1) /= Hash(P2) => P1 /= P2. + with function Hash (Params : Params_Type) return Hash_Value_Type; + + -- Create an object from PARAMS. + with function Build (Params : Params_Type) return Object_Type; + + -- Return True iff OBJ is the object corresponding to PARAMS. + with function Equal (Obj : Object_Type; Params : Params_Type) + return Boolean; +package Interning is + -- Initialize. Required before any other operation. + procedure Init; + + -- If there is already an existing object for PARAMS, return it. + -- Otherwise create it. + function Get (Params : Params_Type) return Object_Type; + + type Index_Type is new Uns32; + No_Index : constant Index_Type := 0; + First_Index : constant Index_Type := 1; + + -- Get the number of elements in the table. + function Last_Index return Index_Type; + + -- Get an element by index. The index has no real meaning, but the + -- current implementation allocates index incrementally. + function Get_By_Index (Index : Index_Type) return Object_Type; +end Interning; diff --git a/src/types.ads b/src/types.ads index 3cf273bd8..2c59f583b 100644 --- a/src/types.ads +++ b/src/types.ads @@ -177,6 +177,4 @@ package Types is -- Result of a comparaison of two numeric values. type Order_Type is (Less, Equal, Greater); - - subtype Hash_Value_Type is Uns32; end Types; 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; |