aboutsummaryrefslogtreecommitdiffstats
path: root/libraries.adb
diff options
context:
space:
mode:
authorTristan Gingold <tgingold@free.fr>2014-11-04 20:14:19 +0100
committerTristan Gingold <tgingold@free.fr>2014-11-04 20:14:19 +0100
commit9c195bf5d86d67ea5eb419ccf6e48dc153e57c68 (patch)
tree575346e529b99e26382b4a06f6ff2caa0b391ab2 /libraries.adb
parent184a123f91e07c927292d67462561dc84f3a920d (diff)
downloadghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.tar.gz
ghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.tar.bz2
ghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.zip
Move sources to src/ subdirectory.
Diffstat (limited to 'libraries.adb')
-rw-r--r--libraries.adb1714
1 files changed, 0 insertions, 1714 deletions
diff --git a/libraries.adb b/libraries.adb
deleted file mode 100644
index 7fd2b69ef..000000000
--- a/libraries.adb
+++ /dev/null
@@ -1,1714 +0,0 @@
--- 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;