-- 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; use Ada.Text_IO; with Ada.Command_Line; use Ada.Command_Line; with GNAT.Directory_Operations; with Types; use Types; with Iir_Chains; with Nodes_Meta; 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; -- 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; Lib_Unit : constant Iir := Get_Library_Unit (Unit); Config : Iir_Design_Unit; begin if (Main or Flags.Dump_All) and then Flags.Dump_Parse then Disp_Tree.Disp_Tree (Unit); end if; if Flags.Verbose then Report_Msg (Msgid_Note, Semantic, +Unit, "analyze %n", (1 => +Lib_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 or else ((Main or Flags.List_All) and then Flags.List_Canon) then if Flags.Verbose then Report_Msg (Msgid_Note, Semantic, No_Location, "canonicalize %n", (1 => +Lib_Unit)); end if; Canon.Canonicalize (Unit); -- FIXME: for Main only ? if Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration and then not Get_Need_Body (Lib_Unit) and then Get_Need_Instance_Bodies (Lib_Unit) then -- Create the bodies for instances Set_Package_Instantiation_Bodies_Chain (Lib_Unit, Canon.Create_Instantiation_Bodies (Lib_Unit, Lib_Unit)); elsif Get_Kind (Lib_Unit) = Iir_Kind_Package_Body and then Get_Need_Instance_Bodies (Get_Package (Lib_Unit)) then Iir_Chains.Append_Chain (Lib_Unit, Nodes_Meta.Field_Declaration_Chain, Canon.Create_Instantiation_Bodies (Get_Package (Lib_Unit), Lib_Unit)); end if; if (Main or Flags.List_All) and then Flags.List_Canon then Disp_Vhdl.Disp_Vhdl (Unit); end if; end if; if Flags.Flag_Elaborate then if Get_Kind (Lib_Unit) = Iir_Kind_Architecture_Body then Config := Canon.Create_Default_Configuration_Declaration (Lib_Unit); Set_Default_Configuration_Declaration (Lib_Unit, Config); end if; end if; end Finish_Compilation; procedure Compile_Init is begin Options.Initialize; Flag_Ieee := Lib_Standard; Back_End.Finish_Compilation := Finish_Compilation'Access; Flag_Verbose := False; end Compile_Init; procedure Init (Cmd : in out Command_Lib) is pragma Unreferenced (Cmd); begin Compile_Init; 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); 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,02 or 08)"); 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 Pathname'First - 1; end Get_Basename_Pos; function Is_Basename (Pathname : String) return Boolean is begin return Get_Basename_Pos (Pathname) < Pathname'First; end Is_Basename; -- Simple lower case conversion, used to compare with "bin". function To_Lower (S : String) return String is Res : String (S'Range); C : Character; begin for I in S'Range loop C := S (I); if C >= 'A' and then C <= 'Z' then C := Character'Val (Character'Pos (C) - Character'Pos ('A') + Character'Pos ('a')); end if; Res (I) := C; end loop; return Res; end To_Lower; procedure Set_Prefix_From_Program_Path (Prog_Path : String) is Last : Natural; begin Last := Get_Basename_Pos (Prog_Path); if Last < Prog_Path'First then -- No directory in Prog_Path. This is not expected. return; end if; declare Pathname : String := Normalize_Pathname (Prog_Path (Last + 1 .. Prog_Path'Last), Prog_Path (Prog_Path'First .. Last - 1)); Pos : Natural; begin -- Stop now in case of error. if Pathname'Length = 0 then return; end if; -- Skip executable name Last := Get_Basename_Pos (Pathname); if Last < Pathname'First then return; end if; -- Simplify path: -- /./ => / -- // => / Pos := Last - 1; while Pos >= Pathname'First loop if Is_Directory_Separator (Pathname (Pos)) then if Is_Directory_Separator (Pathname (Pos + 1)) then -- // => / Pathname (Pos .. Last - 1) := Pathname (Pos + 1 .. Last); Last := Last - 1; elsif Pos + 2 <= Last and then Pathname (Pos + 1) = '.' and then Is_Directory_Separator (Pathname (Pos + 2)) then -- /./ => / Pathname (Pos .. Last - 2) := Pathname (Pos + 2 .. Last); Last := Last - 2; end if; end if; Pos := Pos - 1; end loop; -- Simplify path: -- /xxx/../ => / -- Do it forward as xxx/../../ must not be simplified as xxx/ -- This is done after the previous simplication to avoid to deal -- with cases like /xxx//../ or /xxx/./../ Pos := Pathname'First; while Pos <= Last - 3 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 Last_Dir : Natural; Len : Natural; begin -- Search backward Last_Dir := Pos; loop if Last_Dir = Pathname'First then Last_Dir := Pos; exit; end if; Last_Dir := Last_Dir - 1; exit when Is_Directory_Separator (Pathname (Last_Dir)); end loop; -- /xxxxxxxxxx/../ -- ^ ^ -- Last_Dir Pos Len := Pos + 3 - Last_Dir; Pathname (Last_Dir + 1 .. Last - Len) := Pathname (Pos + 4 .. Last); Last := Last - Len; Pos := Last_Dir; end; else Pos := Pos + 1; end if; end loop; -- Remove last '/' Last := Last - 1; -- Skip '/bin' directory if present Pos := Get_Basename_Pos (Pathname (Pathname'First .. Last)); if Pos < Pathname'First then return; end if; if To_Lower (Pathname (Pos + 1 .. Last)) = "bin" then Last := Pos - 1; end if; Exec_Prefix := new String'(Pathname (Pathname'First .. Last)); 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 not Is_Basename (Prog_Path) 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 Path : constant String := Get_Machine_Path_Prefix & Directory_Separator & Get_Version_Path & Directory_Separator & Name & Directory_Separator; begin if not Is_Directory (Path) then Warning ("library " & Name & " does not exists for " & Get_Version_Path); end if; Libraries.Add_Library_Path (Path); end Add_Library_Path; procedure Setup_Libraries (Load : Boolean) is use Flags; 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 => if Vhdl_Std >= Vhdl_08 then Warning ("--ieee=mentor is ignored for --std=08"); else Add_Library_Path ("mentor"); end if; 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_Config_Prefixes is begin Put ("command line prefix (--PREFIX): "); if Switch_Prefix_Path = null then Put_Line ("(not set)"); else Put_Line (Switch_Prefix_Path.all); end if; Put ("environment prefix (GHDL_PREFIX): "); if Prefix_Env = null then Put_Line ("(not set)"); else Put_Line (Prefix_Env.all); end if; Setup_Libraries (False); Put ("exec prefix (from program name): "); if Exec_Prefix = null then Put_Line ("(not found)"); else Put_Line (Exec_Prefix.all); end if; New_Line; Put_Line ("library prefix: " & Lib_Prefix_Path.all); Put ("library directory: "); Put_Line (Get_Machine_Path_Prefix); end Disp_Config_Prefixes; procedure Disp_Library_Unit (Unit : Iir) is 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 Iir_Kind_Context_Declaration => Put ("context "); when others => Put ("???"); return; end case; Image (Id); Put (Nam_Buffer (1 .. Nam_Length)); case Get_Kind (Unit) is when Iir_Kind_Architecture_Body => Put (" of "); Image (Get_Entity_Identifier_Of_Architecture (Unit)); Put (Nam_Buffer (1 .. Nam_Length)); when Iir_Kind_Configuration_Declaration => if Id = Null_Identifier then Put (" of entity "); Image (Get_Entity_Identifier_Of_Architecture (Unit)); Put (Nam_Buffer (1 .. Nam_Length)); end if; when others => null; end case; end Disp_Library_Unit; procedure Disp_Library (Name : Name_Id) is 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 Is_Directory_Separator (Filename (I)) 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; In_Work : Boolean := True) return String_Access is use Name_Table; begin if In_Work then return new String'(Image (Libraries.Work_Directory) & Get_Base_Name (File) & Suffix); else return new String'(File & Suffix); end if; 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 -- '-d' is for compatibility. 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 "--dir [LIBs] Disp contents of the libraries"; end Get_Short_Help; procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List) is pragma Unreferenced (Cmd); begin Setup_Libraries (True); if Args'Length = 0 then Disp_Library (Std_Names.Name_Work); else for I in Args'Range loop Disp_Library (Name_Table.Get_Identifier (Args (I).all)); 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 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); 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 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 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 (Elab_Prefix & Str); -- Delete file list. Delete (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); -- Try any possible top-level names 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) & Libraries.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_Checksum (Fe), Get_File_Checksum (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; -- Check the Elab_Flag is not set on design units of LIB. 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 the world. 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_Checksum (Fe), Get_File_Checksum (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 during configuration (primary unit not found). raise Option_Error; end if; -- Add unused design units (and their dependencies). 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 (as it is used by below by -- Build_Dependence_List). 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; function Source_File_Modified (File : Iir_Design_File) return Boolean is use Files_Map; Fe : Source_File_Entry; begin -- 2) file has been modified. Fe := Load_Source_File (Get_Design_File_Directory (File), Get_Design_File_Filename (File)); if not Is_Eq (Get_File_Checksum (Fe), Get_File_Checksum (File)) then if Flag_Verbose then Put_Line ("file " & Name_Table.Image (Get_File_Name (Fe)) & " has been modified"); end if; return True; else return False; end if; end Source_File_Modified; function Is_File_Outdated (File : Iir_Design_File) return Boolean is Unit : Iir; Lib_Unit : Iir; begin Unit := Get_First_Design_Unit (File); while Unit /= Null_Iir loop Lib_Unit := Get_Library_Unit (Unit); if Get_Kind (Lib_Unit) = Iir_Kind_Configuration_Declaration and then Get_Identifier (Lib_Unit) = Null_Identifier then -- Do not consider default configurations (there is no user code -- for them). null; elsif Get_Date (Unit) not in Date_Valid then -- Unit not yet analyzed: if Flag_Verbose then Disp_Library_Unit (Get_Library_Unit (Unit)); Put_Line (" was not analyzed"); end if; return True; else -- Check if one of the dependence is newer declare Depends : constant Iir_List := Get_Dependence_List (Unit); Stamp : constant Time_Stamp_Id := Get_Analysis_Time_Stamp (File); El : Iir; Dep : Iir_Design_Unit; Dep_File : Iir_Design_File; begin if Depends /= Null_Iir_List then for I in Natural loop El := Get_Nth_Element (Depends, I); exit when El = Null_Iir; Dep := Libraries.Find_Design_Unit (El); if Dep = Null_Iir then if Flag_Verbose then Disp_Library_Unit (Unit); Put (" depends on an unknown unit "); Disp_Library_Unit (El); New_Line; end if; return True; end if; Dep_File := Get_Design_File (Dep); if Dep /= Std_Package.Std_Standard_Unit and then Files_Map.Is_Gt (Get_Analysis_Time_Stamp (Dep_File), Stamp) then if Flag_Verbose then Disp_Library_Unit (Get_Library_Unit (Unit)); Put (" depends on: "); Disp_Library_Unit (Get_Library_Unit (Dep)); Put (" (more recently analyzed)"); New_Line; end if; return True; end if; end loop; end if; end; end if; Unit := Get_Chain (Unit); end loop; return False; end Is_File_Outdated; -- 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 Nam_Length = 0 then return True; end if; -- Don't try to handle extended identifier. if Nam_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 .. Nam_Length loop case Nam_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 Nam_Length > 4 and then Nam_Buffer (Nam_Length - 3 .. Nam_Length) = ".vhd" then return True; end if; -- Check .vhdl if Nam_Length > 5 and then Nam_Buffer (Nam_Length - 4 .. Nam_Length) = ".vhdl" then return True; end if; -- Check ../ if Nam_Length > 3 and then Nam_Buffer (1 .. 3) = "../" then return True; end if; -- Check ..\ if Nam_Length > 3 and then Nam_Buffer (1 .. 3) = "..\" then return True; end if; -- Should try to find the file ? return False; end Is_A_File_Name; begin Nam_Length := Name'Length; Nam_Buffer (1 .. Nam_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'(Nam_Buffer (1 .. Nam_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;