From 9c195bf5d86d67ea5eb419ccf6e48dc153e57c68 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Tue, 4 Nov 2014 20:14:19 +0100 Subject: Move sources to src/ subdirectory. --- src/libraries.adb | 1714 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1714 insertions(+) create mode 100644 src/libraries.adb (limited to 'src/libraries.adb') diff --git a/src/libraries.adb b/src/libraries.adb new file mode 100644 index 000000000..7fd2b69ef --- /dev/null +++ b/src/libraries.adb @@ -0,0 +1,1714 @@ +-- VHDL libraries handling. +-- 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 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.Text_IO; use Ada.Text_IO; +with GNAT.Table; +with GNAT.OS_Lib; +with Interfaces.C_Streams; +with System; +with Errorout; use Errorout; +with Scanner; +with Iirs_Utils; use Iirs_Utils; +with Parse; +with Back_End; +with Name_Table; use Name_Table; +with Str_Table; +with Sem_Scopes; +with Tokens; +with Files_Map; +with Flags; +with Std_Package; + +package body Libraries is + -- Chain of known libraries. This is also the top node of all iir node. + Libraries_Chain : Iir_Library_Declaration := Null_Iir; + Libraries_Chain_Last : Iir_Library_Declaration := Null_Iir; + + -- A location for any implicit declarations (such as library WORK). + Implicit_Location: Location_Type; + + -- Table of library pathes. + package Pathes is new GNAT.Table + (Table_Index_Type => Integer, + Table_Component_Type => Name_Id, + Table_Low_Bound => 1, + Table_Initial => 4, + Table_Increment => 100); + + -- Initialize pathes table. + -- Set the local path. + procedure Init_Pathes + is + begin + Name_Nil := Get_Identifier (""); + Pathes.Append (Name_Nil); + Local_Directory := Name_Nil; + Work_Directory := Name_Nil; + end Init_Pathes; + + function Path_To_Id (Path : String) return Name_Id is + begin + if Path (Path'Last) /= GNAT.OS_Lib.Directory_Separator then + return Get_Identifier (Path & GNAT.OS_Lib.Directory_Separator); + else + return Get_Identifier (Path); + end if; + end Path_To_Id; + + procedure Add_Library_Path (Path : String) + is + begin + if Path'Length = 0 then + return; + end if; + -- Nice message instead of constraint_error. + if Path'Length + 2 >= Name_Buffer'Length then + Error_Msg ("argument of -P is too long"); + return; + end if; + Pathes.Append (Path_To_Id (Path)); + end Add_Library_Path; + + function Get_Nbr_Pathes return Natural is + begin + return Pathes.Last; + end Get_Nbr_Pathes; + + function Get_Path (N : Natural) return Name_Id is + begin + if N > Pathes.Last or N < Pathes.First then + raise Constraint_Error; + end if; + return Pathes.Table (N); + end Get_Path; + + -- Set PATH as the path of the work library. + procedure Set_Work_Library_Path (Path : String) is + begin + Work_Directory := Path_To_Id (Path); + if not GNAT.OS_Lib.Is_Directory (Get_Address (Work_Directory)) then + -- This is a warning, since 'clean' action should not fail in + -- this cases. + Warning_Msg + ("directory '" & Path & "' set by --workdir= does not exist"); + -- raise Option_Error; + end if; + end Set_Work_Library_Path; + + -- Open LIBRARY map file, return TRUE if successful. + function Set_Library_File_Name (Dir : Name_Id; + Library: Iir_Library_Declaration) + return Boolean + is + File_Name : constant String := Back_End.Library_To_File_Name (Library); + Fe : Source_File_Entry; + begin + Fe := Files_Map.Load_Source_File (Dir, Get_Identifier (File_Name)); + if Fe = No_Source_File_Entry then + return False; + end if; + Scanner.Set_File (Fe); + return True; + end Set_Library_File_Name; + + -- Every design unit is put in this hash table to be quickly found by + -- its (primary) identifier. + Unit_Hash_Length : constant Name_Id := 127; + subtype Hash_Id is Name_Id range 0 .. Unit_Hash_Length - 1; + Unit_Hash_Table : array (Hash_Id) of Iir := (others => Null_Iir); + + -- Get the hash value for DESIGN_UNIT. + -- Architectures use the entity name. + function Get_Hash_Id_For_Unit (Design_Unit : Iir_Design_Unit) + return Hash_Id + is + Lib_Unit : Iir; + Id : Name_Id; + begin + Lib_Unit := Get_Library_Unit (Design_Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Package_Instantiation_Declaration => + Id := Get_Identifier (Lib_Unit); + when Iir_Kind_Architecture_Body => + -- Architectures are put with the entity identifier. + Id := Get_Entity_Identifier_Of_Architecture (Lib_Unit); + when others => + Error_Kind ("get_Hash_Id_For_Unit", Lib_Unit); + end case; + return Id mod Unit_Hash_Length; + end Get_Hash_Id_For_Unit; + + -- Put DESIGN_UNIT into the unit hash table. + procedure Add_Unit_Hash (Design_Unit : Iir) + is + Id : Hash_Id; + begin + Id := Get_Hash_Id_For_Unit (Design_Unit); + Set_Hash_Chain (Design_Unit, Unit_Hash_Table (Id)); + Unit_Hash_Table (Id) := Design_Unit; + end Add_Unit_Hash; + + -- Remove DESIGN_UNIT from the unit hash table. + procedure Remove_Unit_Hash (Design_Unit : Iir) + is + Id : Hash_Id; + Unit, Prev, Next : Iir_Design_Unit; + begin + Id := Get_Hash_Id_For_Unit (Design_Unit); + Unit := Unit_Hash_Table (Id); + Prev := Null_Iir; + while Unit /= Null_Iir loop + Next := Get_Hash_Chain (Unit); + if Unit = Design_Unit then + if Prev = Null_Iir then + Unit_Hash_Table (Id) := Next; + else + Set_Hash_Chain (Prev, Next); + end if; + return; + end if; + Prev := Unit; + Unit := Next; + end loop; + -- Not found. + raise Internal_Error; + end Remove_Unit_Hash; + + procedure Purge_Design_File (Design_File : Iir_Design_File) + is + Prev, File, Next : Iir_Design_File; + Unit : Iir_Design_Unit; + + File_Name : Name_Id; + Dir_Name : Name_Id; + begin + File_Name := Get_Design_File_Filename (Design_File); + Dir_Name := Get_Design_File_Directory (Design_File); + + File := Get_Design_File_Chain (Work_Library); + Prev := Null_Iir; + while File /= Null_Iir loop + Next := Get_Chain (File); + if Get_Design_File_Filename (File) = File_Name + and then Get_Design_File_Directory (File) = Dir_Name + then + -- Remove from library. + if Prev = Null_Iir then + Set_Design_File_Chain (Work_Library, Next); + else + Set_Chain (Prev, Next); + end if; + + -- Remove all units from unit hash table. + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + Remove_Unit_Hash (Unit); + Unit := Get_Chain (Unit); + end loop; + + return; + end if; + Prev := File; + File := Next; + end loop; + end Purge_Design_File; + + -- Load the contents of a library from a map file. + -- The format of this file, used by save_library and load_library is + -- as follow: + -- + -- file_format ::= header { design_file_format } + -- header ::= v 3 + -- design_file_format ::= + -- filename_format { design_unit_format } + -- filename_format ::= + -- FILE directory "FILENAME" file_time_stamp analyze_time_stamp: + -- design_unit_format ::= entity_format + -- | architecture_format + -- | package_format + -- | package_body_format + -- | configuration_format + -- position_format ::= LINE(POS) + OFF on DATE + -- entity_format ::= + -- ENTITY identifier AT position_format ; + -- architecture_format ::= + -- ARCHITECTURE identifier of name AT position_format ; + -- package_format ::= + -- PACKAGE identifier AT position_format [BODY] ; + -- package_body_format ::= + -- PACKAGE BODY identifier AT position_format ; + -- configuration_format ::= + -- CONFIGURATION identifier AT position_format ; + -- + -- The position_format meaning is: + -- LINE is the line number (first line is number 1), + -- POS is the offset of this line number, as a source_ptr value, + -- OFF is the offset in the line, starting with 0. + -- DATE is the symbolic date of analysis (order). + -- + -- Return TRUE if the library was found. + function Load_Library (Library: Iir_Library_Declaration) + return Boolean + is + use Scanner; + use Tokens; + + File : Source_File_Entry; + + procedure Bad_Library_Format is + begin + Error_Msg (Image (Files_Map.Get_File_Name (File)) & + ": bad library format"); + end Bad_Library_Format; + + procedure Scan_Expect (Tok: Token_Type) is + begin + Scan; + if Current_Token /= Tok then + Bad_Library_Format; + raise Compilation_Error; + end if; + end Scan_Expect; + + function Current_Time_Stamp return Time_Stamp_Id is + begin + if Current_String_Length /= Time_Stamp_String'Length then + Bad_Library_Format; + raise Compilation_Error; + end if; + return Time_Stamp_Id (Current_String_Id); + end Current_Time_Stamp; + + function String_To_Name_Id return Name_Id + is + Len : Int32; + Ptr : String_Fat_Acc; + begin + Len := Current_String_Length; + Ptr := Str_Table.Get_String_Fat_Acc (Current_String_Id); + for I in 1 .. Len loop + Name_Table.Name_Buffer (Natural (I)) := Ptr (I); + end loop; + Name_Table.Name_Length := Natural (Len); + -- FIXME: should remove last string. + return Get_Identifier; + end String_To_Name_Id; + + Design_Unit, Last_Design_Unit : Iir_Design_Unit; + Lib_Ident : Name_Id; + + function Scan_Unit_List return Iir_List is + begin + if Current_Token = Tok_Left_Paren then + Scan_Expect (Tok_Identifier); + loop + Scan_Expect (Tok_Dot); + Scan_Expect (Tok_Identifier); + Scan; + if Current_Token = Tok_Left_Paren then + -- This is an architecture. + Scan_Expect (Tok_Identifier); + Scan_Expect (Tok_Right_Paren); + Scan; + end if; + exit when Current_Token /= Tok_Comma; + Scan; + end loop; + Scan; + end if; + return Null_Iir_List; + end Scan_Unit_List; + + Design_File: Iir_Design_File; + Library_Unit: Iir; + Line, Col: Int32; + File_Dir : Name_Id; + Pos: Source_Ptr; + Date: Date_Type; + Max_Date: Date_Type := Date_Valid'First; + Dir : Name_Id; + begin + Lib_Ident := Get_Identifier (Library); + + if False then + Ada.Text_IO.Put_Line ("Load library " & Image (Lib_Ident)); + end if; + + -- Check the library was not already loaded. + if Get_Design_File_Chain (Library) /= Null_Iir then + raise Internal_Error; + end if; + + -- Try to open the library file map. + Dir := Get_Library_Directory (Library); + if Dir = Null_Identifier then + -- Search in the library path. + declare + File_Name : constant String := + Back_End.Library_To_File_Name (Library); + L : Natural; + begin + for I in Pathes.First .. Pathes.Last loop + Image (Pathes.Table (I)); + L := Name_Length + File_Name'Length; + Name_Buffer (Name_Length + 1 .. L) := File_Name; + Name_Buffer (L + 1) := Character'Val (0); + if GNAT.OS_Lib.Is_Regular_File (Name_Buffer'Address) then + Dir := Pathes.Table (I); + Set_Library_Directory (Library, Dir); + exit; + end if; + end loop; + end; + end if; + if Dir = Null_Identifier + or else not Set_Library_File_Name (Dir, Library) + then + -- Not found. + Set_Date (Library, Date_Valid'First); + return False; + end if; + File := Get_Current_Source_File; + + -- Parse header. + Scan; + if Current_Token /= Tok_Identifier + or else Name_Length /= 1 or else Name_Buffer (1) /= 'v' + then + Bad_Library_Format; + raise Compilation_Error; + end if; + Scan_Expect (Tok_Integer); + if Current_Iir_Int64 not in 1 .. 3 then + Bad_Library_Format; + raise Compilation_Error; + end if; + Scan; + + Last_Design_Unit := Null_Iir; + while Current_Token /= Tok_Eof loop + if Current_Token = Tok_File then + -- This is a new design file. + Design_File := Create_Iir (Iir_Kind_Design_File); + + Scan; + if Current_Token = Tok_Dot then + -- The filename is local, use the directory of the library. + if Dir = Name_Nil then + File_Dir := Files_Map.Get_Home_Directory; + else + File_Dir := Dir; + end if; + elsif Current_Token = Tok_Slash then + -- The filename is an absolute file. + File_Dir := Null_Identifier; + elsif Current_Token = Tok_String then + -- Be compatible with version 1: an empty directory for + -- an absolute filename. + if Current_String_Length = 0 then + File_Dir := Null_Identifier; + else + File_Dir := String_To_Name_Id; + end if; + else + Bad_Library_Format; + raise Compilation_Error; + end if; + + Set_Design_File_Directory (Design_File, File_Dir); + + Scan_Expect (Tok_String); + Set_Design_File_Filename (Design_File, String_To_Name_Id); + + -- FIXME: check the file name is uniq. + + Set_Parent (Design_File, Library); + + -- Prepend. + Set_Chain (Design_File, Get_Design_File_Chain (Library)); + Set_Design_File_Chain (Library, Design_File); + + Scan_Expect (Tok_String); + Set_File_Time_Stamp (Design_File, Current_Time_Stamp); + + Scan_Expect (Tok_String); + Set_Analysis_Time_Stamp (Design_File, Current_Time_Stamp); + + Scan_Expect (Tok_Colon); + Scan; + Last_Design_Unit := Null_Iir; + else + -- This is a new design unit. + Design_Unit := Create_Iir (Iir_Kind_Design_Unit); + Set_Design_File (Design_Unit, Design_File); + case Current_Token is + when Tok_Entity => + Library_Unit := Create_Iir (Iir_Kind_Entity_Declaration); + Scan; + when Tok_Architecture => + Library_Unit := Create_Iir (Iir_Kind_Architecture_Body); + Scan; + when Tok_Configuration => + Library_Unit := + Create_Iir (Iir_Kind_Configuration_Declaration); + Scan; + when Tok_Package => + Scan; + if Current_Token = Tok_Body then + Library_Unit := Create_Iir (Iir_Kind_Package_Body); + Scan; + else + Library_Unit := Create_Iir (Iir_Kind_Package_Declaration); + end if; + when Tok_With => + if Library_Unit = Null_Iir + or else + Get_Kind (Library_Unit) /= Iir_Kind_Architecture_Body + then + Put_Line ("load_library: invalid use of 'with'"); + raise Internal_Error; + end if; + Scan_Expect (Tok_Configuration); + Scan_Expect (Tok_Colon); + Scan; + Set_Dependence_List (Design_Unit, Scan_Unit_List); + goto Next_Line; + when others => + Put_Line + ("load_library: line must start with " & + "'architecture', 'entity', 'package' or 'configuration'"); + raise Internal_Error; + end case; + + if Current_Token /= Tok_Identifier then + raise Internal_Error; + end if; + Set_Identifier (Library_Unit, Current_Identifier); + Set_Identifier (Design_Unit, Current_Identifier); + + if Get_Kind (Library_Unit) = Iir_Kind_Architecture_Body then + Scan_Expect (Tok_Of); + Scan_Expect (Tok_Identifier); + Set_Entity_Name (Library_Unit, Current_Text); + end if; + + -- Scan position. + Scan_Expect (Tok_Identifier); -- at + Scan_Expect (Tok_Integer); + Line := Int32 (Current_Iir_Int64); + Scan_Expect (Tok_Left_Paren); + Scan_Expect (Tok_Integer); + Pos := Source_Ptr (Current_Iir_Int64); + Scan_Expect (Tok_Right_Paren); + Scan_Expect (Tok_Plus); + Scan_Expect (Tok_Integer); + Col := Int32 (Current_Iir_Int64); + Scan_Expect (Tok_On); + Scan_Expect (Tok_Integer); + Date := Date_Type (Current_Iir_Int64); + + Scan; + if Get_Kind (Library_Unit) = Iir_Kind_Package_Declaration + and then Current_Token = Tok_Body + then + Set_Need_Body (Library_Unit, True); + Scan; + end if; + if Current_Token /= Tok_Semi_Colon then + raise Internal_Error; + end if; + Scan; + + if False then + Put_Line ("line:" & Int32'Image (Line) + & ", pos:" & Source_Ptr'Image (Pos)); + end if; + + -- Scan dependence list. + Set_Dependence_List (Design_Unit, Scan_Unit_List); + + -- Keep the position of the design unit. + --Set_Location (Design_Unit, Location_Type (File)); + --Set_Location (Library_Unit, Location_Type (File)); + Set_Design_Unit_Source_Pos (Design_Unit, Pos); + Set_Design_Unit_Source_Line (Design_Unit, Line); + Set_Design_Unit_Source_Col (Design_Unit, Col); + Set_Date (Design_Unit, Date); + if Date > Max_Date then + Max_Date := Date; + end if; + Set_Date_State (Design_Unit, Date_Disk); + Set_Library_Unit (Design_Unit, Library_Unit); + Set_Design_Unit (Library_Unit, Design_Unit); + + -- Add in the unit hash table. + Add_Unit_Hash (Design_Unit); + + if Last_Design_Unit = Null_Iir then + Set_First_Design_Unit (Design_File, Design_Unit); + else + Set_Chain (Last_Design_Unit, Design_Unit); + end if; + Last_Design_Unit := Design_Unit; + Set_Last_Design_Unit (Design_File, Design_Unit); + end if; + << Next_Line >> null; + end loop; + Set_Date (Library, Max_Date); + Close_File; + return True; + end Load_Library; + + procedure Create_Virtual_Locations + is + use Files_Map; + Implicit_Source_File : Source_File_Entry; + Command_Source_File : Source_File_Entry; + begin + Implicit_Source_File := Create_Virtual_Source_File + (Get_Identifier ("*implicit*")); + Command_Source_File := Create_Virtual_Source_File + (Get_Identifier ("*command line*")); + Command_Line_Location := Source_File_To_Location (Command_Source_File); + Implicit_Location := Source_File_To_Location (Implicit_Source_File); + end Create_Virtual_Locations; + + -- Note: the scanner shouldn't be in use, since this procedure uses it. + procedure Load_Std_Library (Build_Standard : Boolean := True) + is + use Std_Package; + Dir : Name_Id; + begin + if Libraries_Chain /= Null_Iir then + -- This procedure must not be called twice. + raise Internal_Error; + end if; + + Flags.Create_Flag_String; + Create_Virtual_Locations; + + Std_Package.Create_First_Nodes; + + -- Create the library. + Std_Library := Create_Iir (Iir_Kind_Library_Declaration); + Set_Identifier (Std_Library, Std_Names.Name_Std); + Set_Location (Std_Library, Implicit_Location); + Libraries_Chain := Std_Library; + Libraries_Chain_Last := Std_Library; + + if Build_Standard then + Create_Std_Standard_Package (Std_Library); + Add_Unit_Hash (Std_Standard_Unit); + end if; + + if Flags.Bootstrap + and then Work_Library_Name = Std_Names.Name_Std + then + Dir := Work_Directory; + else + Dir := Null_Identifier; + end if; + Set_Library_Directory (Std_Library, Dir); + if Load_Library (Std_Library) = False + and then not Flags.Bootstrap + then + Error_Msg_Option ("cannot find ""std"" library"); + end if; + + if Build_Standard then + -- Add the standard_file into the library. + -- This is done after Load_Library, because it checks there is no + -- previous files in the library. + Set_Parent (Std_Standard_File, Std_Library); + Set_Chain (Std_Standard_File, Get_Design_File_Chain (Std_Library)); + Set_Design_File_Chain (Std_Library, Std_Standard_File); + end if; + + Set_Visible_Flag (Std_Library, True); + end Load_Std_Library; + + procedure Load_Work_Library (Empty : Boolean := False) + is + use Std_Names; + begin + if Work_Library_Name = Name_Std then + if not Flags.Bootstrap then + Error_Msg_Option ("the WORK library cannot be STD"); + return; + end if; + Work_Library := Std_Library; + else + Work_Library := Create_Iir (Iir_Kind_Library_Declaration); + Set_Location (Work_Library, Implicit_Location); + --Set_Visible_Flag (Work_Library, True); + Set_Library_Directory (Work_Library, Work_Directory); + + Set_Identifier (Work_Library, Work_Library_Name); + + if not Empty then + if Load_Library (Work_Library) = False then + null; + end if; + end if; + + -- Add it to the list of libraries. + Set_Chain (Libraries_Chain_Last, Work_Library); + Libraries_Chain_Last := Work_Library; + end if; + Set_Visible_Flag (Work_Library, True); + end Load_Work_Library; + + -- Get or create a library from an identifier. + function Get_Library (Ident: Name_Id; Loc : Location_Type) + return Iir_Library_Declaration + is + Library: Iir_Library_Declaration; + begin + -- library work is a little bit special. + if Ident = Std_Names.Name_Work or else Ident = Work_Library_Name then + if Work_Library = Null_Iir then + -- load_work_library must have been called before. + raise Internal_Error; + end if; + return Work_Library; + end if; + + -- Check if the library has already been loaded. + Library := Iirs_Utils.Find_Name_In_Chain (Libraries_Chain, Ident); + if Library /= Null_Iir then + return Library; + end if; + + -- This is a new library. + if Ident = Std_Names.Name_Std then + -- Load_std_library must have been called before. + raise Internal_Error; + end if; + + Library := Create_Iir (Iir_Kind_Library_Declaration); + Set_Location (Library, Scanner.Get_Token_Location); + Set_Library_Directory (Library, Null_Identifier); + Set_Identifier (Library, Ident); + if Load_Library (Library) = False then + Error_Msg_Sem ("cannot find resource library """ + & Name_Table.Image (Ident) & """", Loc); + end if; + Set_Visible_Flag (Library, True); + + Set_Chain (Libraries_Chain_Last, Library); + Libraries_Chain_Last := Library; + + return Library; + end Get_Library; + + -- Return TRUE if LIBRARY_UNIT and UNIT have identifiers for the same + -- design unit identifier. + -- eg: 'entity A' and 'package A' returns TRUE. + function Is_Same_Library_Unit (Library_Unit, Unit: Iir) return Boolean + is + Entity_Name1, Entity_Name2: Name_Id; + Library_Unit_Kind, Unit_Kind : Iir_Kind; + begin + if Get_Identifier (Unit) /= Get_Identifier (Library_Unit) then + return False; + end if; + + Library_Unit_Kind := Get_Kind (Library_Unit); + Unit_Kind := Get_Kind (Unit); + + -- Package and package body are never the same library unit. + if Library_Unit_Kind = Iir_Kind_Package_Declaration + and then Unit_Kind = Iir_Kind_Package_Body + then + return False; + end if; + if Unit_Kind = Iir_Kind_Package_Declaration + and then Library_Unit_Kind = Iir_Kind_Package_Body + then + return False; + end if; + + -- Two architecture declarations are identical only if they also have + -- the same entity name. + if Unit_Kind = Iir_Kind_Architecture_Body + and then Library_Unit_Kind = Iir_Kind_Architecture_Body + then + Entity_Name1 := Get_Entity_Identifier_Of_Architecture (Unit); + Entity_Name2 := Get_Entity_Identifier_Of_Architecture (Library_Unit); + if Entity_Name1 /= Entity_Name2 then + return False; + end if; + end if; + + -- An architecture declaration never conflits with a library unit that + -- is not an architecture declaration. + if (Unit_Kind = Iir_Kind_Architecture_Body + and then Library_Unit_Kind /= Iir_Kind_Architecture_Body) + or else + (Unit_Kind /= Iir_Kind_Architecture_Body + and then Library_Unit_Kind = Iir_Kind_Architecture_Body) + then + return False; + end if; + + return True; + end Is_Same_Library_Unit; + + procedure Free_Dependence_List (Design : Iir_Design_Unit) + is + List : Iir_List; + El : Iir; + begin + List := Get_Dependence_List (Design); + if List /= Null_Iir_List then + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Iirs_Utils.Free_Recursive (El); + end loop; + Destroy_Iir_List (List); + end if; + end Free_Dependence_List; + + -- This procedure is called when the DESIGN_UNIT (either the stub created + -- when a library is read or created from a previous unit in a source + -- file) has been replaced by a new unit. Free everything but DESIGN_UNIT, + -- has it may be referenced in other units (dependence...) + -- FIXME: Isn't the library unit also referenced too ? + procedure Free_Design_Unit (Design_Unit : Iir_Design_Unit) + is + Lib : Iir; + Unit : Iir_Design_Unit; + Dep_List : Iir_List; + begin + -- Free dependence list. + Dep_List := Get_Dependence_List (Design_Unit); + Destroy_Iir_List (Dep_List); + Set_Dependence_List (Design_Unit, Null_Iir_List); + + -- Free default configuration of architecture (if any). + Lib := Get_Library_Unit (Design_Unit); + if Lib /= Null_Iir + and then Get_Kind (Lib) = Iir_Kind_Architecture_Body + then + Free_Iir (Get_Entity_Name (Lib)); + Unit := Get_Default_Configuration_Declaration (Lib); + if Unit /= Null_Iir then + Free_Design_Unit (Unit); + end if; + end if; + + -- Free library unit. + Free_Iir (Lib); + Set_Library_Unit (Design_Unit, Null_Iir); + end Free_Design_Unit; + + procedure Remove_Unit_From_File + (Unit_Ref : Iir_Design_Unit; File : Iir_Design_File) + is + Prev : Iir_Design_Unit; + Unit, Next : Iir_Design_Unit; + begin + Prev := Null_Iir; + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + Next := Get_Chain (Unit); + if Unit = Unit_Ref then + if Prev = Null_Iir then + Set_First_Design_Unit (File, Next); + else + Set_Chain (Prev, Next); + end if; + if Next = Null_Iir then + Set_Last_Design_Unit (File, Prev); + end if; + return; + end if; + Prev := Unit; + Unit := Next; + end loop; + -- Not found. + raise Internal_Error; + end Remove_Unit_From_File; + + -- Last design_file used. Kept to speed-up operations. + Last_Design_File : Iir_Design_File := Null_Iir; + + -- Add or replace a design unit in the working library. + procedure Add_Design_Unit_Into_Library + (Unit : in Iir_Design_Unit; Keep_Obsolete : Boolean := False) + is + Design_File: Iir_Design_File; + Design_Unit, Prev_Design_Unit : Iir_Design_Unit; + Last_Unit : Iir_Design_Unit; + Library_Unit: Iir; + New_Library_Unit: Iir; + Unit_Id : Name_Id; + Date: Date_Type; + New_Lib_Time_Stamp : Time_Stamp_Id; + Id : Hash_Id; + + -- File name and dir name of DECL. + File_Name : Name_Id; + Dir_Name : Name_Id; + begin + -- As specified, the Chain must be not set. + pragma Assert (Get_Chain (Unit) = Null_Iir); + + -- The unit must not be in the library. + pragma Assert (Get_Date_State (Unit) = Date_Extern); + + -- Mark this design unit as being loaded. + New_Library_Unit := Get_Library_Unit (Unit); + Unit_Id := Get_Identifier (New_Library_Unit); + + -- Set the date of the design unit as the most recently analyzed + -- design unit. + case Get_Date (Unit) is + when Date_Parsed => + Set_Date_State (Unit, Date_Parse); + when Date_Analyzed => + Date := Get_Date (Work_Library) + 1; + Set_Date (Unit, Date); + Set_Date (Work_Library, Date); + Set_Date_State (Unit, Date_Analyze); + when Date_Valid => + raise Internal_Error; + when others => + raise Internal_Error; + end case; + + -- Set file time stamp. + declare + File : Source_File_Entry; + Pos : Source_Ptr; + begin + Files_Map.Location_To_File_Pos (Get_Location (New_Library_Unit), + File, Pos); + New_Lib_Time_Stamp := Files_Map.Get_File_Time_Stamp (File); + File_Name := Files_Map.Get_File_Name (File); + Image (File_Name); + if GNAT.OS_Lib.Is_Absolute_Path (Name_Buffer (1 .. Name_Length)) then + Dir_Name := Null_Identifier; + else + Dir_Name := Files_Map.Get_Home_Directory; + end if; + end; + + -- Try to find a design unit with the same name in the work library. + Id := Get_Hash_Id_For_Unit (Unit); + Design_Unit := Unit_Hash_Table (Id); + Prev_Design_Unit := Null_Iir; + while Design_Unit /= Null_Iir loop + Design_File := Get_Design_File (Design_Unit); + Library_Unit := Get_Library_Unit (Design_Unit); + if Get_Identifier (Design_Unit) = Unit_Id + and then Get_Library (Design_File) = Work_Library + and then Is_Same_Library_Unit (New_Library_Unit, Library_Unit) + then + -- LIBRARY_UNIT and UNIT designate the same design unit. + -- Remove the old one. + Set_Date (Design_Unit, Date_Obsolete); + declare + Next_Design : Iir; + begin + -- Remove DESIGN_UNIT from the unit_hash. + Next_Design := Get_Hash_Chain (Design_Unit); + if Prev_Design_Unit = Null_Iir then + Unit_Hash_Table (Id) := Next_Design; + else + Set_Hash_Chain (Prev_Design_Unit, Next_Design); + end if; + + -- Remove DESIGN_UNIT from the design_file. + -- If KEEP_OBSOLETE is True, units that are obsoleted by units + -- in the same design file are kept. This allows to process + -- (pretty print, xrefs, ...) all units of a design file. + -- But still remove units that are replaced (if a file was + -- already in the library). + if not Keep_Obsolete + or else Get_Date_State (Design_Unit) = Date_Disk + then + Remove_Unit_From_File (Design_Unit, Design_File); + + Set_Chain (Design_Unit, Obsoleted_Design_Units); + Obsoleted_Design_Units := Design_Unit; + end if; + end; + + -- UNIT *must* replace library_unit if they don't belong + -- to the same file. + if Get_Design_File_Filename (Design_File) = File_Name + and then Get_Design_File_Directory (Design_File) = Dir_Name + then + -- In the same file. + if Get_Date_State (Design_Unit) = Date_Analyze then + -- Warns only if we are not re-analyzing the file. + if Flags.Warn_Library then + Warning_Msg_Sem + ("redefinition of a library unit in " + & "same design file:", Unit); + Warning_Msg_Sem + (Disp_Node (Library_Unit) & " defined at " + & Disp_Location (Library_Unit) & " is now " + & Disp_Node (New_Library_Unit), Unit); + end if; + else + -- Free the stub. + if not Keep_Obsolete then + Free_Design_Unit (Design_Unit); + end if; + end if; + + -- Note: the current design unit should not be freed if + -- in use; unfortunatly, this is not obvious to check. + else + if Flags.Warn_Library then + if Get_Kind (Library_Unit) /= Get_Kind (New_Library_Unit) + then + Warning_Msg ("changing definition of a library unit:"); + Warning_Msg (Disp_Node (Library_Unit) & " is now " + & Disp_Node (New_Library_Unit)); + end if; + Warning_Msg + ("library unit '" + & Iirs_Utils.Image_Identifier (Library_Unit) + & "' was also defined in file '" + & Image (Get_Design_File_Filename (Design_File)) + & '''); + end if; + end if; + exit; + else + Prev_Design_Unit := Design_Unit; + Design_Unit := Get_Hash_Chain (Design_Unit); + end if; + end loop; + + -- Try to find the design file in the library. + -- First try the last one found. + if Last_Design_File /= Null_Iir + and then Get_Library (Last_Design_File) = Work_Library + and then Get_Design_File_Filename (Last_Design_File) = File_Name + and then Get_Design_File_Directory (Last_Design_File) = Dir_Name + then + Design_File := Last_Design_File; + else + -- Search. + Design_File := Get_Design_File_Chain (Work_Library); + while Design_File /= Null_Iir loop + if Get_Design_File_Filename (Design_File) = File_Name + and then Get_Design_File_Directory (Design_File) = Dir_Name + then + exit; + end if; + Design_File := Get_Chain (Design_File); + end loop; + Last_Design_File := Design_File; + end if; + + if Design_File /= Null_Iir + and then not Files_Map.Is_Eq (New_Lib_Time_Stamp, + Get_File_Time_Stamp (Design_File)) + then + -- FIXME: this test is not enough: what about reanalyzing + -- unmodified files (this works only because the order is not + -- changed). + -- Design file is updated. + -- Outdate all other units, overwrite the design_file. + Set_File_Time_Stamp (Design_File, New_Lib_Time_Stamp); + Design_Unit := Get_First_Design_Unit (Design_File); + while Design_Unit /= Null_Iir loop + if Design_Unit /= Unit then + -- Mark other design unit as obsolete. + Set_Date (Design_Unit, Date_Obsolete); + Remove_Unit_Hash (Design_Unit); + else + raise Internal_Error; + end if; + Prev_Design_Unit := Design_Unit; + Design_Unit := Get_Chain (Design_Unit); + + Set_Chain (Prev_Design_Unit, Obsoleted_Design_Units); + Obsoleted_Design_Units := Prev_Design_Unit; + end loop; + Set_First_Design_Unit (Design_File, Null_Iir); + Set_Last_Design_Unit (Design_File, Null_Iir); + end if; + + if Design_File = Null_Iir then + -- This is the first apparition of the design file. + Design_File := Create_Iir (Iir_Kind_Design_File); + Location_Copy (Design_File, Unit); + + Set_Design_File_Filename (Design_File, File_Name); + Set_Design_File_Directory (Design_File, Dir_Name); + + Set_File_Time_Stamp (Design_File, New_Lib_Time_Stamp); + Set_Parent (Design_File, Work_Library); + Set_Chain (Design_File, Get_Design_File_Chain (Work_Library)); + Set_Design_File_Chain (Work_Library, Design_File); + end if; + + -- Add DECL to DESIGN_FILE. + Last_Unit := Get_Last_Design_Unit (Design_File); + if Last_Unit = Null_Iir then + if Get_First_Design_Unit (Design_File) /= Null_Iir then + raise Internal_Error; + end if; + Set_First_Design_Unit (Design_File, Unit); + else + if Get_First_Design_Unit (Design_File) = Null_Iir then + raise Internal_Error; + end if; + Set_Chain (Last_Unit, Unit); + end if; + Set_Last_Design_Unit (Design_File, Unit); + Set_Design_File (Unit, Design_File); + + -- Add DECL in unit hash table. + Set_Hash_Chain (Unit, Unit_Hash_Table (Id)); + Unit_Hash_Table (Id) := Unit; + + -- Update the analyzed time stamp. + Set_Analysis_Time_Stamp (Design_File, Files_Map.Get_Os_Time_Stamp); + end Add_Design_Unit_Into_Library; + + procedure Add_Design_File_Into_Library (File : in out Iir_Design_File) + is + Unit : Iir_Design_Unit; + Next_Unit : Iir_Design_Unit; + First_Unit : Iir_Design_Unit; + begin + Unit := Get_First_Design_Unit (File); + First_Unit := Unit; + Set_First_Design_Unit (File, Null_Iir); + Set_Last_Design_Unit (File, Null_Iir); + while Unit /= Null_Iir loop + Next_Unit := Get_Chain (Unit); + Set_Chain (Unit, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Unit, True); + Unit := Next_Unit; + end loop; + if First_Unit /= Null_Iir then + File := Get_Design_File (First_Unit); + end if; + end Add_Design_File_Into_Library; + + -- Save the file map of library LIBRARY. + procedure Save_Library (Library: Iir_Library_Declaration) + is + use System; + use Interfaces.C_Streams; + use GNAT.OS_Lib; + Temp_Name: constant String := Image (Work_Directory) + & '_' & Back_End.Library_To_File_Name (Library) & ASCII.NUL; + Mode : constant String := 'w' & ASCII.NUL; + Stream : FILEs; + Success : Boolean; + + -- Write a string to the temporary file. + procedure WR (S : String) + is + Close_Res : int; + pragma Unreferenced (Close_Res); + begin + if Integer (fwrite (S'Address, S'Length, 1, Stream)) /= 1 then + Error_Msg + ("cannot write library file for " & Image_Identifier (Library)); + Close_Res := fclose (Stream); + Delete_File (Temp_Name'Address, Success); + -- Ignore failure to delete the file. + raise Option_Error; + end if; + end WR; + + -- Write a line terminator in the temporary file. + procedure WR_LF is + begin + WR (String'(1 => ASCII.LF)); + end WR_LF; + + Design_File: Iir_Design_File; + Design_Unit: Iir_Design_Unit; + Library_Unit: Iir; + Dir : Name_Id; + + Off, Line: Natural; + Pos: Source_Ptr; + Source_File : Source_File_Entry; + begin + -- Create a temporary file so that the real library is atomically + -- updated, and won't be corrupted in case of Control-C, or concurrent + -- writes. + Stream := fopen (Temp_Name'Address, Mode'Address); + + if Stream = NULL_Stream then + Error_Msg + ("cannot create library file for " & Image_Identifier (Library)); + raise Option_Error; + end if; + + -- Header: version. + WR ("v 3"); + WR_LF; + + Design_File := Get_Design_File_Chain (Library); + while Design_File /= Null_Iir loop + -- Ignore std.standard as there is no corresponding file. + if Design_File = Std_Package.Std_Standard_File then + goto Continue; + end if; + Design_Unit := Get_First_Design_Unit (Design_File); + + if Design_Unit /= Null_Iir then + WR ("file "); + Dir := Get_Design_File_Directory (Design_File); + if Dir = Null_Identifier then + -- Absolute filenames. + WR ("/"); + elsif Work_Directory = Name_Nil + and then Dir = Files_Map.Get_Home_Directory + then + -- If the library is in the current directory, do not write + -- it. This allows to move the library file. + WR ("."); + else + Image (Dir); + WR (""""); + WR (Name_Buffer (1 .. Name_Length)); + WR (""""); + end if; + WR (" """); + Image (Get_Design_File_Filename (Design_File)); + WR (Name_Buffer (1 .. Name_Length)); + WR (""" """); + WR (Files_Map.Get_Time_Stamp_String + (Get_File_Time_Stamp (Design_File))); + WR (""" """); + WR (Files_Map.Get_Time_Stamp_String + (Get_Analysis_Time_Stamp (Design_File))); + WR (""":"); + WR_LF; + end if; + + while Design_Unit /= Null_Iir loop + Library_Unit := Get_Library_Unit (Design_Unit); + + WR (" "); + case Get_Kind (Library_Unit) is + when Iir_Kind_Entity_Declaration => + WR ("entity "); + WR (Image_Identifier (Library_Unit)); + when Iir_Kind_Architecture_Body => + WR ("architecture "); + WR (Image_Identifier (Library_Unit)); + WR (" of "); + WR (Image (Get_Entity_Identifier_Of_Architecture + (Library_Unit))); + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + WR ("package "); + WR (Image_Identifier (Library_Unit)); + when Iir_Kind_Package_Body => + WR ("package body "); + WR (Image_Identifier (Library_Unit)); + when Iir_Kind_Configuration_Declaration => + WR ("configuration "); + WR (Image_Identifier (Library_Unit)); + when others => + Error_Kind ("save_library", Library_Unit); + end case; + + if Get_Date_State (Design_Unit) = Date_Disk then + Pos := Get_Design_Unit_Source_Pos (Design_Unit); + Line := Natural (Get_Design_Unit_Source_Line (Design_Unit)); + Off := Natural (Get_Design_Unit_Source_Col (Design_Unit)); + else + Files_Map.Location_To_Coord (Get_Location (Design_Unit), + Source_File, Pos, Line, Off); + end if; + + WR (" at"); + WR (Natural'Image (Line)); + WR ("("); + WR (Source_Ptr'Image (Pos)); + WR (") +"); + WR (Natural'Image (Off)); + WR (" on"); + case Get_Date (Design_Unit) is + when Date_Valid + | Date_Analyzed + | Date_Parsed => + WR (Date_Type'Image (Get_Date (Design_Unit))); + when others => + WR (Date_Type'Image (Get_Date (Design_Unit))); + raise Internal_Error; + end case; + if Get_Kind (Library_Unit) = Iir_Kind_Package_Declaration + and then Get_Need_Body (Library_Unit) + then + WR (" body"); + end if; + WR (";"); + WR_LF; + + Design_Unit := Get_Chain (Design_Unit); + end loop; + << Continue >> null; + Design_File := Get_Chain (Design_File); + end loop; + + declare + Fclose_Res : int; + pragma Unreferenced (Fclose_Res); + begin + Fclose_Res := fclose (Stream); + end; + + -- Rename the temporary file to the library file. + -- FIXME: It may fail if they aren't on the same filesystem, but we + -- could assume it doesn't happen (humm...) + declare + use Files_Map; + File_Name: constant String := Image (Work_Directory) + & Back_End.Library_To_File_Name (Library) & ASCII.NUL; + Delete_Success : Boolean; + begin + -- For windows: renames doesn't overwrite destination; so first + -- delete it. This can create races condition on Unix: if the + -- program is killed between delete and rename, the library is lost. + Delete_File (File_Name'Address, Delete_Success); + Rename_File (Temp_Name'Address, File_Name'Address, Success); + if not Success then + -- Renaming may fail if the new filename is in a non-existant + -- directory. + Error_Msg ("cannot update library file """ + & File_Name (File_Name'First .. File_Name'Last - 1) + & """"); + Delete_File (Temp_Name'Address, Success); + raise Option_Error; + end if; + end; + end Save_Library; + + -- Save the map of the work library. + procedure Save_Work_Library is + begin + Save_Library (Work_Library); + end Save_Work_Library; + + -- Return the name of the latest architecture analysed for an entity. + function Get_Latest_Architecture (Entity: Iir_Entity_Declaration) + return Iir_Architecture_Body + is + Entity_Id : Name_Id; + Lib : Iir_Library_Declaration; + Design_File: Iir_Design_File; + Design_Unit: Iir_Design_Unit; + Library_Unit: Iir; + Res: Iir_Design_Unit; + begin + -- FIXME: use hash + Entity_Id := Get_Identifier (Entity); + Lib := Get_Library (Get_Design_File (Get_Design_Unit (Entity))); + Design_File := Get_Design_File_Chain (Lib); + Res := Null_Iir; + while Design_File /= Null_Iir loop + Design_Unit := Get_First_Design_Unit (Design_File); + while Design_Unit /= Null_Iir loop + Library_Unit := Get_Library_Unit (Design_Unit); + + if Get_Kind (Library_Unit) = Iir_Kind_Architecture_Body + and then + Get_Entity_Identifier_Of_Architecture (Library_Unit) = Entity_Id + then + if Res = Null_Iir then + Res := Design_Unit; + elsif Get_Date (Design_Unit) > Get_Date (Res) then + Res := Design_Unit; + end if; + end if; + Design_Unit := Get_Chain (Design_Unit); + end loop; + Design_File := Get_Chain (Design_File); + end loop; + if Res = Null_Iir then + return Null_Iir; + else + return Get_Library_Unit (Res); + end if; + end Get_Latest_Architecture; + + function Load_File (File : Source_File_Entry) return Iir_Design_File + is + Res : Iir_Design_File; + begin + Scanner.Set_File (File); + Res := Parse.Parse_Design_File; + Scanner.Close_File; + if Res /= Null_Iir then + Set_Parent (Res, Work_Library); + Set_Design_File_Filename (Res, Files_Map.Get_File_Name (File)); + end if; + return Res; + end Load_File; + + -- parse a file. + -- Return a design_file without putting it into the library + -- (because it was not semantized). + function Load_File (File_Name: Name_Id) return Iir_Design_File + is + Fe : Source_File_Entry; + begin + Fe := Files_Map.Load_Source_File (Local_Directory, File_Name); + if Fe = No_Source_File_Entry then + Error_Msg_Option ("cannot open " & Image (File_Name)); + return Null_Iir; + end if; + return Load_File (Fe); + end Load_File; + + function Find_Design_Unit (Unit : Iir) return Iir_Design_Unit is + begin + case Get_Kind (Unit) is + when Iir_Kind_Design_Unit => + return Unit; + when Iir_Kind_Selected_Name => + declare + Lib : Iir_Library_Declaration; + begin + Lib := Get_Library (Get_Identifier (Get_Prefix (Unit)), + Get_Location (Unit)); + return Find_Primary_Unit (Lib, Get_Identifier (Unit)); + end; + when Iir_Kind_Entity_Aspect_Entity => + return Find_Secondary_Unit + (Get_Design_Unit (Get_Entity (Unit)), + Get_Identifier (Get_Architecture (Unit))); + when others => + Error_Kind ("find_design_unit", Unit); + end case; + end Find_Design_Unit; + + function Is_Obsolete (Design_Unit : Iir_Design_Unit; Loc : Iir) + return Boolean + is + procedure Error_Obsolete (Msg : String) is + begin + if not Flags.Flag_Elaborate_With_Outdated then + Error_Msg_Sem (Msg, Loc); + end if; + end Error_Obsolete; + + List : Iir_List; + El : Iir; + Unit : Iir_Design_Unit; + U_Ts : Time_Stamp_Id; + Du_Ts : Time_Stamp_Id; + begin + if Get_Date (Design_Unit) = Date_Obsolete then + Error_Obsolete (Disp_Node (Design_Unit) & " is obsolete"); + return True; + end if; + List := Get_Dependence_List (Design_Unit); + if List = Null_Iir_List then + return False; + end if; + Du_Ts := Get_Analysis_Time_Stamp (Get_Design_File (Design_Unit)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Unit := Find_Design_Unit (El); + if Unit /= Null_Iir then + U_Ts := Get_Analysis_Time_Stamp (Get_Design_File (Unit)); + if Files_Map.Is_Gt (U_Ts, Du_Ts) then + Error_Obsolete + (Disp_Node (Design_Unit) & " is obsoleted by " & + Disp_Node (Unit)); + return True; + elsif Is_Obsolete (Unit, Loc) then + Error_Obsolete + (Disp_Node (Design_Unit) & " depends on obsolete unit"); + return True; + end if; + end if; + end loop; + return False; + end Is_Obsolete; + + procedure Load_Parse_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir) + is + use Scanner; + Line, Off: Natural; + Pos: Source_Ptr; + Res: Iir; + Design_File : Iir_Design_File; + Fe : Source_File_Entry; + begin + -- The unit must not be loaded. + pragma Assert (Get_Date_State (Design_Unit) = Date_Disk); + + -- Load and parse the unit. + Design_File := Get_Design_File (Design_Unit); + Fe := Files_Map.Load_Source_File + (Get_Design_File_Directory (Design_File), + Get_Design_File_Filename (Design_File)); + if Fe = No_Source_File_Entry then + Error_Msg + ("cannot load " & Disp_Node (Get_Library_Unit (Design_Unit))); + raise Compilation_Error; + end if; + Set_File (Fe); + + if not Files_Map.Is_Eq + (Files_Map.Get_File_Time_Stamp (Get_Current_Source_File), + Get_File_Time_Stamp (Design_File)) + then + Error_Msg_Sem + ("file " & Image (Get_Design_File_Filename (Design_File)) + & " has changed and must be reanalysed", Loc); + raise Compilation_Error; + elsif Get_Date (Design_Unit) = Date_Obsolete then + Error_Msg_Sem + (''' & Disp_Node (Get_Library_Unit (Design_Unit)) + & "' is not anymore in the file", + Design_Unit); + raise Compilation_Error; + end if; + Pos := Get_Design_Unit_Source_Pos (Design_Unit); + Line := Natural (Get_Design_Unit_Source_Line (Design_Unit)); + Off := Natural (Get_Design_Unit_Source_Col (Design_Unit)); + Files_Map.File_Add_Line_Number (Get_Current_Source_File, Line, Pos); + Set_Current_Position (Pos + Source_Ptr (Off)); + Res := Parse.Parse_Design_Unit; + Close_File; + if Res = Null_Iir then + raise Compilation_Error; + end if; + Set_Date_State (Design_Unit, Date_Parse); + -- FIXME: check the library unit read is the one expected. + -- Copy node. + Iirs_Utils.Free_Recursive (Get_Library_Unit (Design_Unit)); + Set_Library_Unit (Design_Unit, Get_Library_Unit (Res)); + Set_Design_Unit (Get_Library_Unit (Res), Design_Unit); + Set_Parent (Get_Library_Unit (Res), Design_Unit); + Set_Context_Items (Design_Unit, Get_Context_Items (Res)); + Location_Copy (Design_Unit, Res); + Free_Dependence_List (Design_Unit); + Set_Dependence_List (Design_Unit, Get_Dependence_List (Res)); + Set_Dependence_List (Res, Null_Iir_List); + Free_Iir (Res); + end Load_Parse_Design_Unit; + + -- Load, parse, semantize, back-end a design_unit if necessary. + procedure Load_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir) is + begin + if Get_Date_State (Design_Unit) = Date_Disk then + Load_Parse_Design_Unit (Design_Unit, Loc); + end if; + + if Get_Date_State (Design_Unit) = Date_Parse then + -- Analyze the design unit. + + if Get_Date (Design_Unit) = Date_Analyzed then + -- Work-around for an internal check in sem. + -- FIXME: to be removed ? + Set_Date (Design_Unit, Date_Parsed); + end if; + + -- Avoid infinite recursion, if the unit is self-referenced. + Set_Date_State (Design_Unit, Date_Analyze); + + Sem_Scopes.Push_Interpretations; + Back_End.Finish_Compilation (Design_Unit); + Sem_Scopes.Pop_Interpretations; + + end if; + + case Get_Date (Design_Unit) is + when Date_Parsed => + raise Internal_Error; + when Date_Analyzing => + -- Self-referenced unit. + return; + when Date_Analyzed => + -- FIXME: Accept it silently ? + -- Note: this is used when Flag_Elaborate_With_Outdated is set. + -- This is also used by anonymous configuration declaration. + null; + when Date_Uptodate => + return; + when Date_Valid => + null; + when Date_Obsolete => + if not Flags.Flag_Elaborate_With_Outdated then + Error_Msg_Sem (Disp_Node (Design_Unit) & " is obsolete", Loc); + return; + end if; + when others => + raise Internal_Error; + end case; + + if not Flags.Flag_Elaborate_With_Outdated + and then Is_Obsolete (Design_Unit, Loc) + then + Set_Date (Design_Unit, Date_Obsolete); + end if; + end Load_Design_Unit; + + -- Return the declaration of primary unit NAME of LIBRARY. + function Find_Primary_Unit + (Library: Iir_Library_Declaration; Name: Name_Id) + return Iir_Design_Unit + is + Unit : Iir_Design_Unit; + begin + Unit := Unit_Hash_Table (Name mod Unit_Hash_Length); + while Unit /= Null_Iir loop + if Get_Identifier (Unit) = Name + and then Get_Library (Get_Design_File (Unit)) = Library + then + case Get_Kind (Get_Library_Unit (Unit)) is + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration => + -- Only return a primary unit. + return Unit; + when Iir_Kind_Package_Body + | Iir_Kind_Architecture_Body => + null; + when others => + raise Internal_Error; + end case; + end if; + Unit := Get_Hash_Chain (Unit); + end loop; + + -- The primary unit is not in the library, return null. + return Null_Iir; + end Find_Primary_Unit; + + function Load_Primary_Unit + (Library: Iir_Library_Declaration; Name: Name_Id; Loc : Iir) + return Iir_Design_Unit + is + Design_Unit: Iir_Design_Unit; + begin + Design_Unit := Find_Primary_Unit (Library, Name); + if Design_Unit /= Null_Iir then + Load_Design_Unit (Design_Unit, Loc); + end if; + return Design_Unit; + end Load_Primary_Unit; + + -- Return the declaration of secondary unit NAME for PRIMARY, or null if + -- not found. + function Find_Secondary_Unit (Primary: Iir_Design_Unit; Name: Name_Id) + return Iir_Design_Unit + is + Design_Unit: Iir_Design_Unit; + Library_Unit: Iir; + Primary_Ident: Name_Id; + Lib_Prim : Iir; + begin + Lib_Prim := Get_Library (Get_Design_File (Primary)); + Primary_Ident := Get_Identifier (Get_Library_Unit (Primary)); + Design_Unit := Unit_Hash_Table (Primary_Ident mod Unit_Hash_Length); + while Design_Unit /= Null_Iir loop + Library_Unit := Get_Library_Unit (Design_Unit); + + -- The secondary is always in the same library as the primary. + if Get_Library (Get_Design_File (Design_Unit)) = Lib_Prim then + -- Set design_unit to null iff this is not the correct + -- design unit. + case Get_Kind (Library_Unit) is + when Iir_Kind_Architecture_Body => + -- The entity field can be either an identifier (if the + -- library unit was not loaded) or an access to the entity + -- unit. + if (Get_Entity_Identifier_Of_Architecture (Library_Unit) + = Primary_Ident) + and then Get_Identifier (Library_Unit) = Name + then + return Design_Unit; + end if; + when Iir_Kind_Package_Body => + if Name = Null_Identifier + and then Get_Identifier (Library_Unit) = Primary_Ident + then + return Design_Unit; + end if; + when others => + null; + end case; + end if; + Design_Unit := Get_Hash_Chain (Design_Unit); + end loop; + + -- The architecture or the body is not in the library, return null. + return Null_Iir; + end Find_Secondary_Unit; + + -- Load an secondary unit and analyse it. + function Load_Secondary_Unit + (Primary: Iir_Design_Unit; Name: Name_Id; Loc : Iir) + return Iir_Design_Unit + is + Design_Unit: Iir_Design_Unit; + begin + Design_Unit := Find_Secondary_Unit (Primary, Name); + if Design_Unit /= Null_Iir then + Load_Design_Unit (Design_Unit, Loc); + end if; + return Design_Unit; + end Load_Secondary_Unit; + + function Find_Entity_For_Component (Name: Name_Id) return Iir_Design_Unit + is + Res : Iir_Design_Unit := Null_Iir; + Unit : Iir_Design_Unit; + begin + Unit := Unit_Hash_Table (Name mod Unit_Hash_Length); + while Unit /= Null_Iir loop + if Get_Identifier (Unit) = Name + and then (Get_Kind (Get_Library_Unit (Unit)) + = Iir_Kind_Entity_Declaration) + then + if Res = Null_Iir then + Res := Unit; + else + -- Many entities. + return Null_Iir; + end if; + end if; + Unit := Get_Hash_Chain (Unit); + end loop; + + return Res; + end Find_Entity_For_Component; + + function Get_Libraries_Chain return Iir_Library_Declaration is + begin + return Libraries_Chain; + end Get_Libraries_Chain; +end Libraries; -- cgit v1.2.3