diff options
Diffstat (limited to 'translate/ghdldrv/ghdllocal.adb')
| -rw-r--r-- | translate/ghdldrv/ghdllocal.adb | 1415 |
1 files changed, 0 insertions, 1415 deletions
diff --git a/translate/ghdldrv/ghdllocal.adb b/translate/ghdldrv/ghdllocal.adb deleted file mode 100644 index a1d94bd..0000000 --- a/translate/ghdldrv/ghdllocal.adb +++ /dev/null @@ -1,1415 +0,0 @@ --- GHDL driver - local commands. --- 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 GCC; 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; -with Ada.Command_Line; use Ada.Command_Line; -with GNAT.Directory_Operations; -with Types; use Types; -with Libraries; -with Std_Package; -with Flags; -with Name_Table; -with Std_Names; -with Back_End; -with Disp_Vhdl; -with Default_Pathes; -with Scanner; -with Sem; -with Canon; -with Errorout; -with Configuration; -with Files_Map; -with Post_Sems; -with Disp_Tree; -with Options; -with Iirs_Utils; use Iirs_Utils; - -package body Ghdllocal is - -- Version of the IEEE library to use. This just change pathes. - type Ieee_Lib_Kind is (Lib_Standard, Lib_None, Lib_Synopsys, Lib_Mentor); - Flag_Ieee : Ieee_Lib_Kind; - - Flag_Create_Default_Config : constant Boolean := True; - - -- If TRUE, generate 32bits code on 64bits machines. - Flag_32bit : Boolean := False; - - procedure Finish_Compilation - (Unit : Iir_Design_Unit; Main : Boolean := False) - is - use Errorout; - use Ada.Text_IO; - Config : Iir_Design_Unit; - Lib : Iir; - begin - if (Main or Flags.Dump_All) and then Flags.Dump_Parse then - Disp_Tree.Disp_Tree (Unit); - end if; - - if Flags.Verbose then - Put_Line ("semantize " & Disp_Node (Get_Library_Unit (Unit))); - end if; - - Sem.Semantic (Unit); - - if (Main or Flags.Dump_All) and then Flags.Dump_Sem then - Disp_Tree.Disp_Tree (Unit); - end if; - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if (Main or Flags.List_All) and then Flags.List_Sem then - Disp_Vhdl.Disp_Vhdl (Unit); - end if; - - Post_Sems.Post_Sem_Checks (Unit); - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if Flags.Flag_Elaborate then - if Flags.Verbose then - Put_Line ("canonicalize " & Disp_Node (Get_Library_Unit (Unit))); - end if; - - Canon.Canonicalize (Unit); - - if Flag_Create_Default_Config then - Lib := Get_Library_Unit (Unit); - if Get_Kind (Lib) = Iir_Kind_Architecture_Body then - Config := Canon.Create_Default_Configuration_Declaration (Lib); - Set_Default_Configuration_Declaration (Lib, Config); - end if; - end if; - end if; - end Finish_Compilation; - - procedure Init (Cmd : in out Command_Lib) - is - pragma Unreferenced (Cmd); - begin - Options.Initialize; - Flag_Ieee := Lib_Standard; - Back_End.Finish_Compilation := Finish_Compilation'Access; - Flag_Verbose := False; - end Init; - - procedure Decode_Option (Cmd : in out Command_Lib; - Option : String; - Arg : String; - Res : out Option_Res) - is - pragma Unreferenced (Cmd); - pragma Unreferenced (Arg); - Opt : constant String (1 .. Option'Length) := Option; - begin - Res := Option_Bad; - if Opt = "-v" and then Flag_Verbose = False then - Flag_Verbose := True; - Res := Option_Ok; - elsif Opt'Length > 9 and then Opt (1 .. 9) = "--PREFIX=" then - Switch_Prefix_Path := new String'(Opt (10 .. Opt'Last)); - Res := Option_Ok; - elsif Opt = "--ieee=synopsys" then - Flag_Ieee := Lib_Synopsys; - Res := Option_Ok; - elsif Opt = "--ieee=mentor" then - Flag_Ieee := Lib_Mentor; - Res := Option_Ok; - elsif Opt = "--ieee=none" then - Flag_Ieee := Lib_None; - Res := Option_Ok; - elsif Opt = "--ieee=standard" then - Flag_Ieee := Lib_Standard; - Res := Option_Ok; - elsif Opt = "-m32" then - Flag_32bit := True; - Res := Option_Ok; - elsif Opt'Length >= 2 - and then (Opt (2) = 'g' or Opt (2) = 'O') - then - -- Silently accept -g and -O. - Res := Option_Ok; - else - if Options.Parse_Option (Opt) then - Res := Option_Ok; - end if; - end if; - end Decode_Option; - - procedure Disp_Long_Help (Cmd : Command_Lib) - is - pragma Unreferenced (Cmd); - use Ada.Text_IO; - procedure P (Str : String) renames Put_Line; - begin - P ("Main options (try --options-help for details):"); - P (" --std=XX Use XX as VHDL standard (87,93c,93,00 or 02)"); - P (" --work=NAME Set the name of the WORK library"); - P (" -PDIR Add DIR in the library search path"); - P (" --workdir=DIR Specify the directory of the WORK library"); - P (" --PREFIX=DIR Specify installation prefix"); - P (" --ieee=NAME Use NAME as ieee library, where name is:"); - P (" standard: standard version (default)"); - P (" synopsys, mentor: vendor version (not advised)"); - P (" none: do not use a predefined ieee library"); - end Disp_Long_Help; - - function Is_Directory_Separator (C : Character) return Boolean is - begin - return C = '/' or else C = Directory_Separator; - end Is_Directory_Separator; - - function Get_Basename_Pos (Pathname : String) return Natural is - begin - for I in reverse Pathname'Range loop - if Is_Directory_Separator (Pathname (I)) then - return I; - end if; - end loop; - return 0; - end Get_Basename_Pos; - - procedure Set_Prefix_From_Program_Path (Prog_Path : String) - is - Dir_Pos : Natural; - begin - Dir_Pos := Get_Basename_Pos (Prog_Path); - if Dir_Pos = 0 then - -- No directory in Prog_Path. This is not expected. - return; - end if; - - declare - Pathname : String := - Normalize_Pathname (Prog_Path (Dir_Pos + 1 .. Prog_Path'Last), - Prog_Path (Prog_Path'First .. Dir_Pos - 1)); - Pos : Natural; - begin - -- Stop now in case of error. - if Pathname'Length = 0 then - return; - end if; - - -- Skip executable name - Dir_Pos := Get_Basename_Pos (Pathname); - if Dir_Pos = 0 then - return; - end if; - - -- Simplify path: - -- /./ => / - -- // => / - Pos := Dir_Pos - 1; - while Pos >= Pathname'First loop - if Is_Directory_Separator (Pathname (Pos)) then - if Is_Directory_Separator (Pathname (Pos + 1)) then - -- // => / - Pathname (Pos .. Dir_Pos - 1) := - Pathname (Pos + 1 .. Dir_Pos); - Dir_Pos := Dir_Pos - 1; - elsif Pos + 2 <= Dir_Pos - and then Pathname (Pos + 1) = '.' - and then Is_Directory_Separator (Pathname (Pos + 2)) - then - -- /./ => / - Pathname (Pos .. Dir_Pos - 2) := - Pathname (Pos + 2 .. Dir_Pos); - Dir_Pos := Dir_Pos - 2; - end if; - end if; - Pos := Pos - 1; - end loop; - - -- Simplify path: - -- /xxx/../ => / - -- This is done after the previous simplication to avoid to deal - -- with cases like /xxx//../ or /xxx/./../ - Pos := Dir_Pos - 3; - while Pos >= Pathname'First loop - if Is_Directory_Separator (Pathname (Pos)) - and then Pathname (Pos + 1) = '.' - and then Pathname (Pos + 2) = '.' - and then Is_Directory_Separator (Pathname (Pos + 3)) - then - declare - Pos2 : constant Natural := - Get_Basename_Pos (Pathname (Pathname'First .. Pos - 1)); - -- /xxxxxxxxxx/../ - -- ^ ^ - -- Pos2 Pos - Len : Natural; - begin - if Pos2 = 0 then - -- Shouldn't happen. - return; - end if; - Len := Pos + 3 - Pos2; - Pathname (Pos2 + 1 .. Dir_Pos - Len) := - Pathname (Pos + 4 .. Dir_Pos); - Dir_Pos := Dir_Pos - Len; - if Pos2 < Pathname'First + 3 then - exit; - end if; - Pos := Pos2 - 3; - end; - else - Pos := Pos - 1; - end if; - end loop; - - -- Remove last '/' - Dir_Pos := Dir_Pos - 1; - - -- Skip directory. - Dir_Pos := Get_Basename_Pos (Pathname (Pathname'First .. Dir_Pos)); - if Dir_Pos = 0 then - return; - end if; - - Exec_Prefix := new String'(Pathname (Pathname'First .. Dir_Pos - 1)); - end; - end Set_Prefix_From_Program_Path; - - -- Extract Exec_Prefix from executable name. - procedure Set_Exec_Prefix - is - use GNAT.Directory_Operations; - Prog_Path : constant String := Ada.Command_Line.Command_Name; - Exec_Path : String_Access; - begin - -- If the command name is an absolute path, deduce prefix from it. - if Is_Absolute_Path (Prog_Path) then - Set_Prefix_From_Program_Path (Prog_Path); - return; - end if; - - -- If the command name is a relative path, deduce prefix from it - -- and current path. - if Get_Basename_Pos (Prog_Path) /= 0 then - if Is_Executable_File (Prog_Path) then - Set_Prefix_From_Program_Path - (Get_Current_Dir & Directory_Separator & Prog_Path); - end if; - return; - end if; - - -- Look for program name on the path. - Exec_Path := Locate_Exec_On_Path (Prog_Path); - if Exec_Path /= null then - Set_Prefix_From_Program_Path (Exec_Path.all); - Free (Exec_Path); - end if; - end Set_Exec_Prefix; - - function Get_Version_Path return String - is - use Flags; - begin - case Vhdl_Std is - when Vhdl_87 => - return "v87"; - when Vhdl_93c - | Vhdl_93 - | Vhdl_00 - | Vhdl_02 => - return "v93"; - when Vhdl_08 => - return "v08"; - end case; - end Get_Version_Path; - - function Get_Machine_Path_Prefix return String is - begin - if Flag_32bit then - return Lib_Prefix_Path.all & "32"; - else - return Lib_Prefix_Path.all; - end if; - end Get_Machine_Path_Prefix; - - procedure Add_Library_Path (Name : String) - is - begin - Libraries.Add_Library_Path - (Get_Machine_Path_Prefix & Directory_Separator - & Get_Version_Path & Directory_Separator - & Name & Directory_Separator); - end Add_Library_Path; - - procedure Setup_Libraries (Load : Boolean) - is - begin - -- Get environment variable. - Prefix_Env := GNAT.OS_Lib.Getenv ("GHDL_PREFIX"); - if Prefix_Env = null or else Prefix_Env.all = "" then - Prefix_Env := null; - end if; - - -- Compute Exec_Prefix. - Set_Exec_Prefix; - - -- Set prefix path. - -- If not set by command line, try environment variable. - if Switch_Prefix_Path /= null then - Lib_Prefix_Path := Switch_Prefix_Path; - else - Lib_Prefix_Path := Prefix_Env; - end if; - -- Else try default path. - if Lib_Prefix_Path = null then - if Is_Absolute_Path (Default_Pathes.Lib_Prefix) then - Lib_Prefix_Path := new String'(Default_Pathes.Lib_Prefix); - else - if Exec_Prefix /= null then - Lib_Prefix_Path := new - String'(Exec_Prefix.all & Directory_Separator - & Default_Pathes.Lib_Prefix); - end if; - if Lib_Prefix_Path = null - or else not Is_Directory (Lib_Prefix_Path.all) - then - Free (Lib_Prefix_Path); - Lib_Prefix_Path := new - String'(Default_Pathes.Install_Prefix - & Directory_Separator - & Default_Pathes.Lib_Prefix); - end if; - end if; - else - -- Assume the user has set the correct path, so do not insert 32. - Flag_32bit := False; - end if; - - -- Add pathes for predefined libraries. - if not Flags.Bootstrap then - Add_Library_Path ("std"); - case Flag_Ieee is - when Lib_Standard => - Add_Library_Path ("ieee"); - when Lib_Synopsys => - Add_Library_Path ("synopsys"); - when Lib_Mentor => - Add_Library_Path ("mentor"); - when Lib_None => - null; - end case; - end if; - if Load then - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - end if; - end Setup_Libraries; - - procedure Disp_Library_Unit (Unit : Iir) - is - use Ada.Text_IO; - use Name_Table; - Id : Name_Id; - begin - Id := Get_Identifier (Unit); - case Get_Kind (Unit) is - when Iir_Kind_Entity_Declaration => - Put ("entity "); - when Iir_Kind_Architecture_Body => - Put ("architecture "); - when Iir_Kind_Configuration_Declaration => - Put ("configuration "); - when Iir_Kind_Package_Declaration => - Put ("package "); - when Iir_Kind_Package_Instantiation_Declaration => - Put ("package instance "); - when Iir_Kind_Package_Body => - Put ("package body "); - when others => - Put ("???"); - return; - end case; - Image (Id); - Put (Name_Buffer (1 .. Name_Length)); - case Get_Kind (Unit) is - when Iir_Kind_Architecture_Body => - Put (" of "); - Image (Get_Entity_Identifier_Of_Architecture (Unit)); - Put (Name_Buffer (1 .. Name_Length)); - when Iir_Kind_Configuration_Declaration => - if Id = Null_Identifier then - Put ("<default> of entity "); - Image (Get_Entity_Identifier_Of_Architecture (Unit)); - Put (Name_Buffer (1 .. Name_Length)); - end if; - when others => - null; - end case; - end Disp_Library_Unit; - - procedure Disp_Library (Name : Name_Id) - is - use Ada.Text_IO; - use Libraries; - Lib : Iir_Library_Declaration; - File : Iir_Design_File; - Unit : Iir; - begin - if Name = Std_Names.Name_Work then - Lib := Work_Library; - elsif Name = Std_Names.Name_Std then - Lib := Std_Library; - else - Lib := Get_Library (Name, Command_Line_Location); - end if; - - -- Disp contents of files. - File := Get_Design_File_Chain (Lib); - while File /= Null_Iir loop - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - Disp_Library_Unit (Get_Library_Unit (Unit)); - New_Line; - Unit := Get_Chain (Unit); - end loop; - File := Get_Chain (File); - end loop; - end Disp_Library; - - -- Return FILENAME without the extension. - function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True) - return String - is - First : Natural; - Last : Natural; - begin - First := Filename'First; - Last := Filename'Last; - for I in Filename'Range loop - if Filename (I) = '.' then - Last := I - 1; - elsif Remove_Dir and then Filename (I) = Directory_Separator then - First := I + 1; - Last := Filename'Last; - end if; - end loop; - return Filename (First .. Last); - end Get_Base_Name; - - function Append_Suffix (File : String; Suffix : String) return String_Access - is - use Name_Table; - Basename : constant String := Get_Base_Name (File); - begin - Image (Libraries.Work_Directory); - Name_Buffer (Name_Length + 1 .. Name_Length + Basename'Length) := - Basename; - Name_Length := Name_Length + Basename'Length; - Name_Buffer (Name_Length + 1 .. Name_Length + Suffix'Length) := Suffix; - Name_Length := Name_Length + Suffix'Length; - return new String'(Name_Buffer (1 .. Name_Length)); - end Append_Suffix; - - - -- Command Dir. - type Command_Dir is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean; - function Get_Short_Help (Cmd : Command_Dir) return String; - procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List); - - function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-d" or else Name = "--dir"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Dir) return String - is - pragma Unreferenced (Cmd); - begin - return "-d or --dir Disp contents of the work library"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - if Args'Length /= 0 then - Error ("command '-d' does not accept any argument"); - raise Option_Error; - end if; - - Flags.Bootstrap := True; - -- Load word library. - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - - Disp_Library (Std_Names.Name_Work); - --- else --- for L in Libs'Range loop --- Id := Get_Identifier (Libs (L).all); --- Disp_Library (Id); --- end loop; --- end if; - end Perform_Action; - - -- Command Find. - type Command_Find is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Find; Name : String) return Boolean; - function Get_Short_Help (Cmd : Command_Find) return String; - procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List); - - function Decode_Command (Cmd : Command_Find; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-f"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Find) return String - is - pragma Unreferenced (Cmd); - begin - return "-f FILEs Disp units in FILES"; - end Get_Short_Help; - - -- Return TRUE is UNIT can be at the apex of a design hierarchy. - function Is_Top_Entity (Unit : Iir) return Boolean - is - begin - if Get_Kind (Unit) /= Iir_Kind_Entity_Declaration then - return False; - end if; - if Get_Port_Chain (Unit) /= Null_Iir then - return False; - end if; - if Get_Generic_Chain (Unit) /= Null_Iir then - return False; - end if; - return True; - end Is_Top_Entity; - - -- Disp contents design files FILES. - procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List) - is - pragma Unreferenced (Cmd); - - use Ada.Text_IO; - use Name_Table; - Id : Name_Id; - Design_File : Iir_Design_File; - Unit : Iir; - Lib : Iir; - Flag_Add : constant Boolean := False; - begin - Flags.Bootstrap := True; - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - - for I in Args'Range loop - Id := Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - if Design_File /= Null_Iir then - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - Lib := Get_Library_Unit (Unit); - Disp_Library_Unit (Lib); - if Is_Top_Entity (Lib) then - Put (" **"); - end if; - New_Line; - if Flag_Add then - Libraries.Add_Design_Unit_Into_Library (Unit); - end if; - Unit := Get_Chain (Unit); - end loop; - end if; - end loop; - if Flag_Add then - Libraries.Save_Work_Library; - end if; - end Perform_Action; - - -- Command Import. - type Command_Import is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Import; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Import) return String; - procedure Perform_Action (Cmd : in out Command_Import; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Import; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-i"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Import) return String - is - pragma Unreferenced (Cmd); - begin - return "-i [OPTS] FILEs Import units of FILEs"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Import; Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Ada.Text_IO; - Id : Name_Id; - Design_File : Iir_Design_File; - Unit : Iir; - Next_Unit : Iir; - Lib : Iir; - begin - Setup_Libraries (True); - - -- Parse all files. - for I in Args'Range loop - Id := Name_Table.Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - if Design_File /= Null_Iir then - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - if Flag_Verbose then - Lib := Get_Library_Unit (Unit); - Disp_Library_Unit (Lib); - if Is_Top_Entity (Lib) then - Put (" **"); - end if; - New_Line; - end if; - Next_Unit := Get_Chain (Unit); - Set_Chain (Unit, Null_Iir); - Libraries.Add_Design_Unit_Into_Library (Unit); - Unit := Next_Unit; - end loop; - end if; - end loop; - - -- Analyze all files. - if False then - Design_File := Get_Design_File_Chain (Libraries.Work_Library); - while Design_File /= Null_Iir loop - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - case Get_Date (Unit) is - when Date_Valid - | Date_Analyzed => - null; - when Date_Parsed => - Back_End.Finish_Compilation (Unit, False); - when others => - raise Internal_Error; - end case; - Unit := Get_Chain (Unit); - end loop; - Design_File := Get_Chain (Design_File); - end loop; - end if; - - Libraries.Save_Work_Library; - exception - when Errorout.Compilation_Error => - Error ("importation has failed due to compilation error"); - raise; - end Perform_Action; - - -- Command Check_Syntax. - type Command_Check_Syntax is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Check_Syntax; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Check_Syntax) return String; - procedure Perform_Action (Cmd : in out Command_Check_Syntax; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Check_Syntax; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-s"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Check_Syntax) return String - is - pragma Unreferenced (Cmd); - begin - return "-s [OPTS] FILEs Check syntax of FILEs"; - end Get_Short_Help; - - procedure Analyze_One_File (File_Name : String) - is - use Ada.Text_IO; - Id : Name_Id; - Design_File : Iir_Design_File; - Unit : Iir; - Next_Unit : Iir; - begin - Id := Name_Table.Get_Identifier (File_Name); - if Flag_Verbose then - Put (File_Name); - Put_Line (":"); - end if; - Design_File := Libraries.Load_File (Id); - if Design_File = Null_Iir then - raise Errorout.Compilation_Error; - end if; - - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - if Flag_Verbose then - Put (' '); - Disp_Library_Unit (Get_Library_Unit (Unit)); - New_Line; - end if; - -- Sem, canon, annotate a design unit. - Back_End.Finish_Compilation (Unit, True); - - Next_Unit := Get_Chain (Unit); - if Errorout.Nbr_Errors = 0 then - Set_Chain (Unit, Null_Iir); - Libraries.Add_Design_Unit_Into_Library (Unit); - end if; - - Unit := Next_Unit; - end loop; - - if Errorout.Nbr_Errors > 0 then - raise Errorout.Compilation_Error; - end if; - end Analyze_One_File; - - procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) is - begin - Setup_Libraries (True); - - -- Parse all files. - for I in Files'Range loop - Analyze_One_File (Files (I).all); - end loop; - - if Save_Library then - Libraries.Save_Work_Library; - end if; - end Analyze_Files; - - procedure Perform_Action (Cmd : in out Command_Check_Syntax; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - Analyze_Files (Args, False); - end Perform_Action; - - -- Command --clean: remove object files. - type Command_Clean is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean; - function Get_Short_Help (Cmd : Command_Clean) return String; - procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List); - - function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--clean"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Clean) return String - is - pragma Unreferenced (Cmd); - begin - return "--clean Remove generated files"; - end Get_Short_Help; - - procedure Delete (Str : String) - is - use Ada.Text_IO; - Status : Boolean; - begin - Delete_File (Str'Address, Status); - if Flag_Verbose and Status then - Put_Line ("delete " & Str (Str'First .. Str'Last - 1)); - end if; - end Delete; - - procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Name_Table; - - procedure Delete_Asm_Obj (Str : String) is - begin - Delete (Str & Get_Object_Suffix.all & Nul); - Delete (Str & Asm_Suffix & Nul); - end Delete_Asm_Obj; - - procedure Delete_Top_Unit (Str : String) is - begin - -- Delete elaboration file - Delete_Asm_Obj (Image (Libraries.Work_Directory) & Elab_Prefix & Str); - - -- Delete file list. - Delete (Image (Libraries.Work_Directory) & Str & List_Suffix & Nul); - - -- Delete executable. - Delete (Str & Nul); - end Delete_Top_Unit; - - File : Iir_Design_File; - Design_Unit : Iir_Design_Unit; - Lib_Unit : Iir; - Str : String_Access; - begin - if Args'Length /= 0 then - Error ("command '--clean' does not accept any argument"); - raise Option_Error; - end if; - - Flags.Bootstrap := True; - -- Load libraries. - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - - File := Get_Design_File_Chain (Libraries.Work_Library); - while File /= Null_Iir loop - -- Delete compiled file. - Str := Append_Suffix (Image (Get_Design_File_Filename (File)), ""); - Delete_Asm_Obj (Str.all); - Free (Str); - - Design_Unit := Get_First_Design_Unit (File); - while Design_Unit /= Null_Iir loop - Lib_Unit := Get_Library_Unit (Design_Unit); - case Get_Kind (Lib_Unit) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Configuration_Declaration => - Delete_Top_Unit (Image (Get_Identifier (Lib_Unit))); - when Iir_Kind_Architecture_Body => - Delete_Top_Unit - (Image (Get_Entity_Identifier_Of_Architecture (Lib_Unit)) - & '-' - & Image (Get_Identifier (Lib_Unit))); - when others => - null; - end case; - Design_Unit := Get_Chain (Design_Unit); - end loop; - File := Get_Chain (File); - end loop; - end Perform_Action; - - -- Command --remove: remove object file and library file. - type Command_Remove is new Command_Clean with null record; - function Decode_Command (Cmd : Command_Remove; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Remove) return String; - procedure Perform_Action (Cmd : in out Command_Remove; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Remove; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--remove"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Remove) return String - is - pragma Unreferenced (Cmd); - begin - return "--remove Remove generated files and library file"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Remove; Args : Argument_List) - is - use Name_Table; - begin - if Args'Length /= 0 then - Error ("command '--remove' does not accept any argument"); - raise Option_Error; - end if; - Perform_Action (Command_Clean (Cmd), Args); - Delete (Image (Libraries.Work_Directory) - & Back_End.Library_To_File_Name (Libraries.Work_Library) - & Nul); - end Perform_Action; - - -- Command --copy: copy work library to current directory. - type Command_Copy is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean; - function Get_Short_Help (Cmd : Command_Copy) return String; - procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List); - - function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--copy"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Copy) return String - is - pragma Unreferenced (Cmd); - begin - return "--copy Copy work library to current directory"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Name_Table; - use Libraries; - - File : Iir_Design_File; - Dir : Name_Id; - begin - if Args'Length /= 0 then - Error ("command '--copy' does not accept any argument"); - raise Option_Error; - end if; - - Setup_Libraries (False); - Libraries.Load_Std_Library; - Dir := Work_Directory; - Work_Directory := Null_Identifier; - Libraries.Load_Work_Library; - Work_Directory := Dir; - - Dir := Get_Library_Directory (Libraries.Work_Library); - if Dir = Name_Nil or else Dir = Files_Map.Get_Home_Directory then - Error ("cannot copy library on itself (use --remove first)"); - raise Option_Error; - end if; - - File := Get_Design_File_Chain (Libraries.Work_Library); - while File /= Null_Iir loop - -- Copy object files (if any). - declare - Basename : constant String := - Get_Base_Name (Image (Get_Design_File_Filename (File))); - Src : String_Access; - Dst : String_Access; - Success : Boolean; - pragma Unreferenced (Success); - begin - Src := new String'(Image (Dir) & Basename & Get_Object_Suffix.all); - Dst := new String'(Basename & Get_Object_Suffix.all); - Copy_File (Src.all, Dst.all, Success, Overwrite, Full); - -- Be silent in case of error. - Free (Src); - Free (Dst); - end; - if Get_Design_File_Directory (File) = Name_Nil then - Set_Design_File_Directory (File, Dir); - end if; - - File := Get_Chain (File); - end loop; - Libraries.Work_Directory := Name_Nil; - Libraries.Save_Work_Library; - end Perform_Action; - - -- Command --disp-standard. - type Command_Disp_Standard is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Disp_Standard; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Disp_Standard) return String; - procedure Perform_Action (Cmd : in out Command_Disp_Standard; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Disp_Standard; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--disp-standard"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Disp_Standard) return String - is - pragma Unreferenced (Cmd); - begin - return "--disp-standard Disp std.standard in pseudo-vhdl"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Disp_Standard; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - if Args'Length /= 0 then - Error ("command '--disp-standard' does not accept any argument"); - raise Option_Error; - end if; - Flags.Bootstrap := True; - Libraries.Load_Std_Library; - Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit); - end Perform_Action; - - procedure Load_All_Libraries_And_Files - is - use Files_Map; - use Libraries; - use Errorout; - - procedure Extract_Library_Clauses (Unit : Iir_Design_Unit) - is - Lib1 : Iir_Library_Declaration; - pragma Unreferenced (Lib1); - Ctxt_Item : Iir; - begin - -- Extract library clauses. - Ctxt_Item := Get_Context_Items (Unit); - while Ctxt_Item /= Null_Iir loop - if Get_Kind (Ctxt_Item) = Iir_Kind_Library_Clause then - Lib1 := Get_Library (Get_Identifier (Ctxt_Item), - Get_Location (Ctxt_Item)); - end if; - Ctxt_Item := Get_Chain (Ctxt_Item); - end loop; - end Extract_Library_Clauses; - - Lib : Iir_Library_Declaration; - Fe : Source_File_Entry; - File, Next_File : Iir_Design_File; - Unit, Next_Unit : Iir_Design_Unit; - Design_File : Iir_Design_File; - - Old_Work : Iir_Library_Declaration; - begin - Lib := Std_Library; - Lib := Get_Chain (Lib); - Old_Work := Work_Library; - while Lib /= Null_Iir loop - -- Design units are always put in the work library. - Work_Library := Lib; - - File := Get_Design_File_Chain (Lib); - while File /= Null_Iir loop - Next_File := Get_Chain (File); - Fe := Load_Source_File (Get_Design_File_Directory (File), - Get_Design_File_Filename (File)); - if Fe = No_Source_File_Entry then - -- FIXME: should remove all the design file from the library. - null; - elsif Is_Eq (Get_File_Time_Stamp (Fe), - Get_File_Time_Stamp (File)) - then - -- File has not been modified. - -- Extract libraries. - -- Note: we can't parse it only, since we need to keep the - -- date. - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - Load_Parse_Design_Unit (Unit, Null_Iir); - Extract_Library_Clauses (Unit); - Unit := Get_Chain (Unit); - end loop; - else - -- File has been modified. - -- Parse it. - Design_File := Load_File (Fe); - - -- Exit now in case of parse error. - if Design_File = Null_Iir - or else Nbr_Errors > 0 - then - raise Compilation_Error; - end if; - - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - Extract_Library_Clauses (Unit); - - Next_Unit := Get_Chain (Unit); - Set_Chain (Unit, Null_Iir); - Add_Design_Unit_Into_Library (Unit); - Unit := Next_Unit; - end loop; - end if; - File := Next_File; - end loop; - Lib := Get_Chain (Lib); - end loop; - Work_Library := Old_Work; - end Load_All_Libraries_And_Files; - - procedure Check_No_Elab_Flag (Lib : Iir_Library_Declaration) - is - File : Iir_Design_File; - Unit : Iir_Design_Unit; - begin - File := Get_Design_File_Chain (Lib); - while File /= Null_Iir loop - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - if Get_Elab_Flag (Unit) then - raise Internal_Error; - end if; - Unit := Get_Chain (Unit); - end loop; - File := Get_Chain (File); - end loop; - end Check_No_Elab_Flag; - - function Build_Dependence (Prim : String_Access; Sec : String_Access) - return Iir_List - is - procedure Build_Dependence_List (File : Iir_Design_File; List : Iir_List) - is - El : Iir_Design_File; - Depend_List : Iir_List; - begin - if Get_Elab_Flag (File) then - return; - end if; - - Set_Elab_Flag (File, True); - Depend_List := Get_File_Dependence_List (File); - if Depend_List /= Null_Iir_List then - for I in Natural loop - El := Get_Nth_Element (Depend_List, I); - exit when El = Null_Iir; - Build_Dependence_List (El, List); - end loop; - end if; - Append_Element (List, File); - end Build_Dependence_List; - - use Configuration; - use Name_Table; - - Top : Iir; - Primary_Id : Name_Id; - Secondary_Id : Name_Id; - - File : Iir_Design_File; - Unit : Iir; - - Files_List : Iir_List; - begin - Check_No_Elab_Flag (Libraries.Work_Library); - - Primary_Id := Get_Identifier (Prim.all); - if Sec /= null then - Secondary_Id := Get_Identifier (Sec.all); - else - Secondary_Id := Null_Identifier; - end if; - - if True then - Load_All_Libraries_And_Files; - else - -- Re-parse modified files in order configure could find all design - -- units. - declare - use Files_Map; - Fe : Source_File_Entry; - Next_File : Iir_Design_File; - Design_File : Iir_Design_File; - begin - File := Get_Design_File_Chain (Libraries.Work_Library); - while File /= Null_Iir loop - Next_File := Get_Chain (File); - Fe := Load_Source_File (Get_Design_File_Directory (File), - Get_Design_File_Filename (File)); - if Fe = No_Source_File_Entry then - -- FIXME: should remove all the design file from - -- the library. - null; - else - if not Is_Eq (Get_File_Time_Stamp (Fe), - Get_File_Time_Stamp (File)) - then - -- FILE has been modified. - Design_File := Libraries.Load_File (Fe); - if Design_File /= Null_Iir then - Libraries.Add_Design_File_Into_Library (Design_File); - end if; - end if; - end if; - File := Next_File; - end loop; - end; - end if; - - Flags.Flag_Elaborate := True; - Flags.Flag_Elaborate_With_Outdated := True; - Flag_Load_All_Design_Units := True; - Flag_Build_File_Dependence := True; - - Top := Configure (Primary_Id, Secondary_Id); - if Top = Null_Iir then - --Error ("cannot find primary unit " & Prim.all); - raise Option_Error; - end if; - - -- Add unused design units. - declare - N : Natural; - begin - N := Design_Units.First; - while N <= Design_Units.Last loop - Unit := Design_Units.Table (N); - N := N + 1; - File := Get_Design_File (Unit); - if not Get_Elab_Flag (File) then - Set_Elab_Flag (File, True); - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - if not Get_Elab_Flag (Unit) then - Add_Design_Unit (Unit, Null_Iir); - end if; - Unit := Get_Chain (Unit); - end loop; - end if; - end loop; - end; - - -- Clear elab flag on design files. - for I in reverse Design_Units.First .. Design_Units.Last loop - Unit := Design_Units.Table (I); - File := Get_Design_File (Unit); - Set_Elab_Flag (File, False); - end loop; - - -- Create a list of files, from the last to the first. - Files_List := Create_Iir_List; - for I in Design_Units.First .. Design_Units.Last loop - Unit := Design_Units.Table (I); - File := Get_Design_File (Unit); - Build_Dependence_List (File, Files_List); - end loop; - - return Files_List; - end Build_Dependence; - - -- Convert NAME to lower cases, unless it is an extended identifier. - function Convert_Name (Name : String_Access) return String_Access - is - use Name_Table; - - function Is_Bad_Unit_Name return Boolean is - begin - if Name_Length = 0 then - return True; - end if; - -- Don't try to handle extended identifier. - if Name_Buffer (1) = '\' then - return False; - end if; - -- Look for suspicious characters. - -- Do not try to be exhaustive as the correct check will be done - -- by convert_identifier. - for I in 1 .. Name_Length loop - case Name_Buffer (I) is - when '.' | '/' | '\' => - return True; - when others => - null; - end case; - end loop; - return False; - end Is_Bad_Unit_Name; - - function Is_A_File_Name return Boolean is - begin - -- Check .vhd - if Name_Length > 4 - and then Name_Buffer (Name_Length - 3 .. Name_Length) = ".vhd" - then - return True; - end if; - -- Check .vhdl - if Name_Length > 5 - and then Name_Buffer (Name_Length - 4 .. Name_Length) = ".vhdl" - then - return True; - end if; - -- Check ../ - if Name_Length > 3 - and then Name_Buffer (1 .. 3) = "../" - then - return True; - end if; - -- Check ..\ - if Name_Length > 3 - and then Name_Buffer (1 .. 3) = "..\" - then - return True; - end if; - -- Should try to find the file ? - return False; - end Is_A_File_Name; - begin - Name_Length := Name'Length; - Name_Buffer (1 .. Name_Length) := Name.all; - - -- Try to identifier bad names (such as file names), so that - -- friendly message can be displayed. - if Is_Bad_Unit_Name then - Errorout.Error_Msg_Option_NR ("bad unit name '" & Name.all & "'"); - if Is_A_File_Name then - Errorout.Error_Msg_Option_NR - ("(a unit name is required instead of a filename)"); - end if; - raise Option_Error; - end if; - Scanner.Convert_Identifier; - return new String'(Name_Buffer (1 .. Name_Length)); - end Convert_Name; - - procedure Extract_Elab_Unit - (Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural) - is - begin - if Args'Length = 0 then - Error ("command '" & Cmd_Name & "' required an unit name"); - raise Option_Error; - end if; - - Prim_Name := Convert_Name (Args (Args'First)); - Next_Arg := Args'First + 1; - Sec_Name := null; - - if Args'Length >= 2 then - declare - Sec : constant String_Access := Args (Next_Arg); - begin - if Sec (Sec'First) /= '-' then - Sec_Name := Convert_Name (Sec); - Next_Arg := Args'First + 2; - end if; - end; - end if; - end Extract_Elab_Unit; - - procedure Register_Commands is - begin - Register_Command (new Command_Import); - Register_Command (new Command_Check_Syntax); - Register_Command (new Command_Dir); - Register_Command (new Command_Find); - Register_Command (new Command_Clean); - Register_Command (new Command_Remove); - Register_Command (new Command_Copy); - Register_Command (new Command_Disp_Standard); - end Register_Commands; -end Ghdllocal; |