ghdldrv.adb

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

      Index := 3;
      for I in Files'Range loop
         Comp_List (Index) := Flag_C;
         Comp_List (Index + 1) := Files (I);
         Index := Index + 2;
      end loop;
      Do_Compile (Comp_List, Elab_Name.all);
      Free (Flag_C);
      Free (Comp_List (1));
   end Bind_Anaelab;

   procedure Link (Add_Std : Boolean;
                   Disp_Only : Boolean)
   is
      Last_File : Natural;
   begin
      --  read files list
      if Filelist_Name /= null then
         Add_File_List (Filelist_Name.all, True);
      end if;
      Last_File := Filelist.Last;
      Add_File_List (Prefix_Path.all & "grt" & List_Suffix, False);

      --  call the linker
      declare
         P : Natural;
         Nbr_Args : Natural := Last (Linker_Args) + Filelist.Last + 4;
         Args : Argument_List (1 .. Nbr_Args);
         Obj_File : String_Access;
         Std_File : String_Access;
      begin
         Obj_File := Append_Suffix
           (Elab_Name.all, Get_Object_Suffix.all);
         P := 0;
         Args (P + 1) := Dash_O;
         Args (P + 2) := Output_File;
         Args (P + 3) := Obj_File;
         P := P + 3;
         if Add_Std then
            Std_File := new
              String'(Prefix_Path.all
                      & Get_Version_Path & Directory_Separator
                      & "std" & Directory_Separator
                      & "std_standard" & Get_Object_Suffix.all);
            P := P + 1;
            Args (P) := Std_File;
         else
            Std_File := null;
         end if;

         --  Object files of the design.
         for I in Filelist.First .. Last_File loop
            P := P + 1;
            Args (P) := Filelist.Table (I);
         end loop;
         --  User added options.
         for I in First .. Last (Linker_Args) loop
            P := P + 1;
            Args (P) := Linker_Args.Table (I);
         end loop;
         --  GRT files (should be the last one, since it contains an
         --  optional main).
         for I in Last_File + 1 .. Filelist.Last loop
            P := P + 1;
            Args (P) := Filelist.Table (I);
         end loop;

         if Disp_Only then
            for I in 3 .. P loop
               Put_Line (Args (I).all);
            end loop;
         else
            My_Spawn (Linker_Path.all, Args (1 .. P));
         end if;

         Free (Obj_File);
         Free (Std_File);
      end;

      for I in Filelist.First .. Filelist.Last loop
         Free (Filelist.Table (I));
      end loop;
   end Link;

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

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

   function Get_Short_Help (Cmd : Command_Elab) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "-e [OPTS] UNIT [ARCH]      Elaborate UNIT";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_Elab; Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
      Success : Boolean;
   begin
      Set_Elab_Units ("-e", Args);
      Setup_Compiler (False);

      Bind;
      if not Flag_Expect_Failure then
         Link (Add_Std => True, Disp_Only => False);
      end if;
      Delete_File (Filelist_Name.all, Success);
   end Perform_Action;

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

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

   function Get_Short_Help (Cmd : Command_Run) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "-r UNIT [ARCH] [OPTS]      Run UNIT";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_Run; Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
      Opt_Arg : Natural;
   begin
      Extract_Elab_Unit ("-r", Args, Opt_Arg);
      if Sec_Name = null then
         Base_Name := Prim_Name;
      else
         Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all);
      end if;
      if not Is_Regular_File (Base_Name.all & Nul) then
         Error ("file '" & Base_Name.all & "' does not exists");
         Error ("Please elaborate your design.");
         raise Exec_Error;
      end if;
      My_Spawn ('.' & Directory_Separator & Base_Name.all,
                Args (Opt_Arg .. Args'Last));
   end Perform_Action;

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

   function Decode_Command (Cmd : Command_Elab_Run; Name : String)
                           return Boolean
   is
      pragma Unreferenced (Cmd);
   begin
      return Name = "--elab-run";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Elab_Run) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "--elab-run [OPTS] UNIT [ARCH] [OPTS]  Elaborate and run UNIT";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_Elab_Run;
                             Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
      Success : Boolean;
      Run_Arg : Natural;
   begin
      Set_Elab_Units ("-elab-run", Args, Run_Arg);
      Setup_Compiler (False);

      Bind;
      if Flag_Expect_Failure then
         Delete_File (Filelist_Name.all, Success);
      else
         Link (Add_Std => True, Disp_Only => False);
         Delete_File (Filelist_Name.all, Success);
         My_Spawn ('.' & Directory_Separator & Output_File.all,
                   Args (Run_Arg .. Args'Last));
      end if;
   end Perform_Action;

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

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

   function Get_Short_Help (Cmd : Command_Bind) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "--bind [OPTS] UNIT [ARCH]  Bind UNIT";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_Bind; Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
   begin
      Set_Elab_Units ("--bind", Args);
      Setup_Compiler (False);

      Bind;
   end Perform_Action;

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

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

   function Get_Short_Help (Cmd : Command_Link) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "--link [OPTS] UNIT [ARCH]  Link UNIT";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
   begin
      Set_Elab_Units ("--link", Args);
      Setup_Compiler (False);

      Filelist_Name := new String'(Elab_Name.all & List_Suffix);
      Link (Add_Std => True, Disp_Only => False);
   end Perform_Action;


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

   function Decode_Command (Cmd : Command_List_Link; Name : String)
                           return Boolean
   is
      pragma Unreferenced (Cmd);
   begin
      return Name = "--list-link";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_List_Link) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "--list-link [OPTS] UNIT [ARCH]  List objects file to link UNIT";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_List_Link;
                             Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
   begin
      Set_Elab_Units ("--list-link", Args);
      Setup_Compiler (False);

      Filelist_Name := new String'(Elab_Name.all & List_Suffix);
      Link (Add_Std => True, Disp_Only => True);
   end Perform_Action;


   --  Command analyze and elaborate
   type Command_Anaelab is new Command_Comp with null record;
   function Decode_Command (Cmd : Command_Anaelab; Name : String)
                           return Boolean;
   function Get_Short_Help (Cmd : Command_Anaelab) return String;
   procedure Decode_Option (Cmd : in out Command_Anaelab;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res);

   procedure Perform_Action (Cmd : in out Command_Anaelab;
                             Args : Argument_List);

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

   function Get_Short_Help (Cmd : Command_Anaelab) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "-c [OPTS] FILEs -e UNIT [ARCH]  "
        & "Generate whole code to elab UNIT from FILEs";
   end Get_Short_Help;

   procedure Decode_Option (Cmd : in out Command_Anaelab;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res)
   is
   begin
      if Option = "-e" then
         Res := Option_End;
         return;
      else
         Decode_Option (Command_Comp (Cmd), Option, Arg, Res);
      end if;
   end Decode_Option;

   procedure Perform_Action (Cmd : in out Command_Anaelab;
                             Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
      Elab_Index : Integer;
   begin
      Elab_Index := -1;
      for I in Args'Range loop
         if Args (I).all = "-e" then
            Elab_Index := I;
            exit;
         end if;
      end loop;
      if Elab_Index < 0 then
         Analyze_Files (Args, True);
      else
         Set_Elab_Units ("-c", Args (Elab_Index + 1 .. Args'Last));
         Setup_Compiler (False);

         Bind_Anaelab (Args (Args'First .. Elab_Index - 1));
         Link (Add_Std => False, Disp_Only => False);
      end if;
   end Perform_Action;

   --  Command Make.
   type Command_Make is new Command_Comp with record
      --  Disp dependences during make.
      Flag_Depend_Unit : Boolean;

      --  Force recompilation of units in work library.
      Flag_Force : Boolean;
   end record;

   function Decode_Command (Cmd : Command_Make; Name : String)
                           return Boolean;
   procedure Init (Cmd : in out Command_Make);
   procedure Decode_Option (Cmd : in out Command_Make;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res);

   function Get_Short_Help (Cmd : Command_Make) return String;
   procedure Disp_Long_Help (Cmd : Command_Make);

   procedure Perform_Action (Cmd : in out Command_Make;
                             Args : Argument_List);

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

   function Get_Short_Help (Cmd : Command_Make) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "-m [OPTS] UNIT [ARCH]  Make UNIT";
   end Get_Short_Help;

   procedure Disp_Long_Help (Cmd : Command_Make)
   is
   begin
      Disp_Long_Help (Command_Comp (Cmd));
      Put_Line (" -f             Force recompilation of work units");
      Put_Line (" -Mu            Disp unit dependences (humna format)");
   end Disp_Long_Help;

   procedure Init (Cmd : in out Command_Make) is
   begin