ghdldrv.adb

vhdl集成电路设计软件.需要用gcc-4.0.2版本编译.

         El : Iir;
         Dep : Iir_Design_Unit;
         Stamp : Time_Stamp_Id;
         Dep_File : Iir_Design_File;
      begin
         Depends := Get_Dependence_List (Unit);
         Stamp := Get_Analysis_Time_Stamp (Design_File);
         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;

      return False;
   end Is_Unit_Outdated;

   procedure Add_Argument (Inst : in out Instance; Arg : String_Access)
   is
   begin
      Increment_Last (Inst);
      Inst.Table (Last (Inst)) := Arg;
   end Add_Argument;

   --  Convert option "-Wx,OPTIONS" to arguments for tool X.
   procedure Add_Arguments (Inst : in out Instance; Opt : String) is
   begin
      Add_Argument (Inst, new String'(Opt (Opt'First + 4 .. Opt'Last)));
   end Add_Arguments;

   procedure Tool_Not_Found (Name : String) is
   begin
      Error ("installation problem: " & Name & " not found");
      raise Option_Error;
   end Tool_Not_Found;

   procedure Set_Tools_Name
   is
   begin
      --  Set tools name.
      if Compiler_Cmd = null then
         case Compile_Kind is
            when Compile_Debug =>
               Compiler_Cmd := new String'(Default_Pathes.Compiler_Debug);
            when Compile_Gcc =>
               Compiler_Cmd := new String'(Default_Pathes.Compiler_Gcc);
            when Compile_Mcode =>
               Compiler_Cmd := new String'(Default_Pathes.Compiler_Mcode);
         end case;
      end if;
      if Post_Processor_Cmd = null then
         Post_Processor_Cmd := new String'(Default_Pathes.Post_Processor);
      end if;
   end Set_Tools_Name;

   procedure Locate_Tools
   is
   begin
      Compiler_Path := Locate_Exec_On_Path (Compiler_Cmd.all);
      if Compiler_Path = null then
         Tool_Not_Found (Compiler_Cmd.all);
      end if;
      if Compile_Kind >= Compile_Debug then
         Post_Processor_Path := Locate_Exec_On_Path (Post_Processor_Cmd.all);
         if Post_Processor_Path = null then
            Tool_Not_Found (Post_Processor_Cmd.all);
         end if;
      end if;
      if Compile_Kind >= Compile_Gcc then
         Assembler_Path := Locate_Exec_On_Path (Assembler_Cmd);
         if Assembler_Path = null and not Flag_Asm then
            Tool_Not_Found (Assembler_Cmd);
         end if;
      end if;
      Linker_Path := Locate_Exec_On_Path (Linker_Cmd);
      if Linker_Path = null then
         Tool_Not_Found (Linker_Cmd);
      end if;
      Dash_O := new String'("-o");
      Dash_S := new String'("-S");
      Dash_Quiet := new String'("-quiet");
   end Locate_Tools;

   procedure Setup_Compiler (Load : Boolean)
   is
      use Libraries;
   begin
      Set_Tools_Name;
      Locate_Tools;
      Setup_Libraries (Load);
      for I in 2 .. Get_Nbr_Pathes loop
         Add_Argument (Compiler_Args,
                       new String'("-P" & Image (Get_Path (I))));
      end loop;
   end Setup_Compiler;

   type Command_Comp is abstract new Command_Lib with null record;

   --  Setup GHDL.
   procedure Init (Cmd : in out Command_Comp);

   --  Handle:
   --  all ghdl flags.
   --  some GCC flags.
   procedure Decode_Option (Cmd : in out Command_Comp;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res);

   procedure Disp_Long_Help (Cmd : Command_Comp);

   procedure Init (Cmd : in out Command_Comp)
   is
   begin
      --  Init options.
      Flag_Not_Quiet := False;
      Flag_Disp_Commands := False;
      Flag_Asm := False;
      Compile_Kind := Compile_Gcc;
      Flag_Expect_Failure := False;
      Output_File := null;

      --  Initialize argument tables.
      Init (Compiler_Args);
      Init (Postproc_Args);
      Init (Assembler_Args);
      Init (Linker_Args);
      Init (Command_Lib (Cmd));
   end Init;

   procedure Decode_Option (Cmd : in out Command_Comp;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res)
   is
      Str : String_Access;
   begin
      Res := Option_Bad;
      if Option = "-v" and then Flag_Verbose = False then
         --  Note: this is also decoded for command_lib, but we set
         --  Flag_Disp_Commands too.
         Flag_Verbose := True;
         --Flags.Verbose := True;
         Flag_Disp_Commands := True;
         Res := Option_Ok;
      elsif Option'Length > 8 and then Option (1 .. 8) = "--GHDL1=" then
         Compiler_Cmd := new String'(Option (9 .. Option'Last));
         Res := Option_Ok;
      elsif Option = "-S" then
         Flag_Asm := True;
         Res := Option_Ok;
      elsif Option = "--post" then
         Compile_Kind := Compile_Debug;
         Res := Option_Ok;
      elsif Option = "--mcode" then
         Compile_Kind := Compile_Mcode;
         Res := Option_Ok;
      elsif Option = "-o" then
         if Arg'Length = 0 then
            Res := Option_Arg_Req;
         else
            Output_File := new String'(Arg);
            Res := Option_Arg;
         end if;
      elsif Option'Length > 4
        and then Option (2) = 'W' and then Option (4) = ','
      then
         if Option (3) = 'c' then
            Add_Arguments (Compiler_Args, Option);
         elsif Option (3) = 'a' then
            Add_Arguments (Assembler_Args, Option);
         elsif Option (3) = 'p' then
            Add_Arguments (Postproc_Args, Option);
         elsif Option (3) = 'l' then
            Add_Arguments (Linker_Args, Option);
         else
            Error
              ("unknown tool name in '-W" & Option (3) & ",' option");
            raise Option_Error;
         end if;
         Res := Option_Ok;
      elsif Option'Length >= 2 and then Option (2) = 'g' then
         --  Debugging option.
         Str := new String'(Option);
         Add_Argument (Compiler_Args, Str);
         Add_Argument (Linker_Args, Str);
         Res := Option_Ok;
      elsif Option = "-Q" then
         Flag_Not_Quiet := True;
         Res := Option_Ok;
      elsif Option = "--expect-failure" then
         Add_Argument (Compiler_Args, new String'(Option));
         Flag_Expect_Failure := True;
         Res := Option_Ok;
      elsif Flags.Parse_Option (Option) then
         Add_Argument (Compiler_Args, new String'(Option));
         Res := Option_Ok;
      elsif Option'Length >= 2
        and then (Option (2) = 'O' or Option (2) = 'f')
      then
         --  Optimization option.
         --  This is put after Flags.Parse_Option, since it may catch -fxxx
         --  options.
         Add_Argument (Compiler_Args, new String'(Option));
         Res := Option_Ok;
      else
         Decode_Option (Command_Lib (Cmd), Option, Arg, Res);
      end if;
   end Decode_Option;

   procedure Disp_Long_Help (Cmd : Command_Comp)
   is
      use Ada.Text_IO;
   begin
      Disp_Long_Help (Command_Lib (Cmd));
      Put_Line (" -v             Be verbose");
      Put_Line (" --GHDL1=PATH   Set the path of the ghdl1 compiler");
      Put_Line (" -S             Do not assemble");
      Put_Line (" -o FILE        Set the name of the output file");
      Put_Line (" -WX,OPTION     Pass OPTION to X, where X is one of");
      Put_Line ("                 c: compiler, a: assembler, l: linker");
      Put_Line (" -g[XX]         Pass debugging option to the compiler");
      Put_Line (" -O[XX]/-f[XX]  Pass optimization option to the compiler");
      Put_Line (" -Q             Do not add -quiet option to compiler");
      Put_Line (" --expect-failure  Expect analysis/elaboration failure");
   end Disp_Long_Help;

   --  Command dispconfig.
   type Command_Dispconfig is new Command_Comp with null record;
   function Decode_Command (Cmd : Command_Dispconfig; Name : String)
                           return Boolean;
   function Get_Short_Help (Cmd : Command_Dispconfig) return String;
   procedure Perform_Action (Cmd : in out Command_Dispconfig;
                             Args : Argument_List);

   function Decode_Command (Cmd : Command_Dispconfig; Name : String)
                           return Boolean
   is
      pragma Unreferenced (Cmd);
   begin
      return Name = "--dispconfig";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Dispconfig) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "--dispconfig       Disp tools path";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_Dispconfig;
                             Args : Argument_List)
   is
      use Ada.Text_IO;
      use Libraries;
      pragma Unreferenced (Cmd);
   begin
      if Args'Length /= 0 then
         Error ("--dispconfig does not accept any argument");
         raise Option_Error;
      end if;

      Set_Tools_Name;
      Put ("compiler command: ");
      Put_Line (Compiler_Cmd.all);
      if Compile_Kind >= Compile_Debug then
         Put ("post-processor command: ");
         Put_Line (Post_Processor_Cmd.all);
      end if;
      if Compile_Kind >= Compile_Gcc then
         Put ("assembler command: ");
         Put_Line (Assembler_Cmd);
      end if;
      Put ("linker command: ");
      Put_Line (Linker_Cmd);
      Setup_Libraries (False);
      Put ("library directory: ");
      Put_Line (Prefix_Path.all);
      Locate_Tools;
      Put ("compiler path: ");
      Put_Line (Compiler_Path.all);
      if Compile_Kind >= Compile_Debug then
         Put ("post-processor path: ");
         Put_Line (Post_Processor_Path.all);
      end if;
      if Compile_Kind >= Compile_Gcc then
         Put ("assembler path: ");
         Put_Line (Assembler_Path.all);
      end if;
      Put ("linker path: ");
      Put_Line (Linker_Path.all);
      Put_Line ("default library pathes:");
      for I in 2 .. Get_Nbr_Pathes loop
         Put (' ');
         Put_Line (Image (Get_Path (I)));
      end loop;
   end Perform_Action;

   --  Command Analyze.
   type Command_Analyze is new Command_Comp with null record;
   function Decode_Command (Cmd : Command_Analyze; Name : String)
                           return Boolean;
   function Get_Short_Help (Cmd : Command_Analyze) return String;
   procedure Perform_Action (Cmd : in out Command_Analyze;
                             Args : Argument_List);

   function Decode_Command (Cmd : Command_Analyze; Name : String)
                           return Boolean
   is
      pragma Unreferenced (Cmd);
   begin
      return Name = "-a";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Analyze) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "-a [OPTS] FILEs    Analyze FILEs";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_Analyze;
                             Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
      Nil_Opt : Argument_List (2 .. 1);
   begin
      if Args'Length = 0 then
         Error ("no file to analyze");
         raise Option_Error;
      end if;
      Setup_Compiler (False);

      for I in Args'Range loop
         Do_Compile (Nil_Opt, Args (I).all);
      end loop;
   end Perform_Action;

   --  Elaboration.

   Base_Name : String_Access;
   Elab_Name : String_Access;
   Filelist_Name : String_Access;
   Unit_Name : String_Access;

   procedure Set_Elab_Units (Cmd_Name : String;
                             Args : Argument_List;
                             Run_Arg : out Natural)
   is
   begin
      Extract_Elab_Unit (Cmd_Name, Args, Run_Arg);
      if Sec_Name = null then
         Base_Name := Prim_Name;
         Unit_Name := Prim_Name;
      else
         Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all);
         Unit_Name := new String'(Prim_Name.all & '(' & Sec_Name.all & ')');
      end if;

      Elab_Name := new String'(Elab_Prefix & Base_Name.all);
      Filelist_Name := null;

      if Output_File = null then
         Output_File := new String'(Base_Name.all);
      end if;
   end Set_Elab_Units;

   procedure Set_Elab_Units (Cmd_Name : String; Args : Argument_List)
   is
      Next_Arg : Natural;
   begin
      Set_Elab_Units (Cmd_Name, Args, Next_Arg);
      if Next_Arg <= Args'Last then
         Error ("too many unit names for command '" & Cmd_Name & "'");
         raise Option_Error;
      end if;
   end Set_Elab_Units;

   procedure Bind
   is
      Comp_List : Argument_List (1 .. 4);
   begin
      Filelist_Name := new String'(Elab_Name.all & List_Suffix);

      Comp_List (1) := new String'("--elab");
      Comp_List (2) := Unit_Name;
      Comp_List (3) := new String'("-l");
      Comp_List (4) := Filelist_Name;
      Do_Compile (Comp_List, Elab_Name.all);
      Free (Comp_List (3));
      Free (Comp_List (1));
   end Bind;

   procedure Bind_Anaelab (Files : Argument_List)
   is
      Comp_List : Argument_List (1 .. 2 * Files'Length + 2);
      Flag_C : String_Access;
      Index : Natural;
   begin
      Comp_List (1) := new String'("--anaelab");
      Comp_List (2) := Unit_Name;
      Flag_C := new String'("-c");