path: root/translate/ghdldrv/ghdlcomp.adb

--  GHDL driver - compile 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 Ghdlmain; use Ghdlmain;
with Ghdllocal; use Ghdllocal;

with Ada.Command_Line;
with Ada.Characters.Latin_1;
with Ada.Text_IO;

with Types;
with Iirs; use Iirs;
with Flags;
with Back_End;
with Sem;
with Name_Table;
with Errorout; use Errorout;
with Libraries;
with Std_Package;
with Files_Map;
with Version;
with Default_Pathes;

package body Ghdlcomp is

   Flag_Expect_Failure : Boolean := False;

   --  Commands which use the mcode compiler.
   type Command_Comp is abstract new Command_Lib with null record;
   procedure Decode_Option (Cmd : in out Command_Comp;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res);
   procedure Disp_Long_Help (Cmd : Command_Comp);

   procedure Decode_Option (Cmd : in out Command_Comp;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res)
   is
   begin
      if Option = "--expect-failure" then
         Flag_Expect_Failure := True;
         Res := Option_Ok;
      elsif Hooks.Decode_Option.all (Option) then
         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));
      Hooks.Disp_Long_Help.all;
      Put_Line (" --expect-failure  Expect analysis/elaboration failure");
   end Disp_Long_Help;

   --  Command -r
   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" or Name = "--elab-run";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Run) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "-r,--elab-run [OPTS] UNIT [ARCH] [RUNOPTS]  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
      begin
         Hooks.Compile_Init.all (False);

         Libraries.Load_Work_Library (False);
         Flags.Flag_Elaborate_With_Outdated := False;
         Flags.Flag_Only_Elab_Warnings := True;

         Hooks.Compile_Elab.all ("-r", Args, Opt_Arg);
      exception
         when Compilation_Error =>
            if Flag_Expect_Failure then
               return;
            else
               raise;
            end if;
      end;
      Hooks.Set_Run_Options (Args (Opt_Arg .. Args'Last));
      Hooks.Run.all;
   end Perform_Action;


   --  Command -c xx -r
   type Command_Compile is new Command_Comp with null record;
   function Decode_Command (Cmd : Command_Compile; Name : String)
                           return Boolean;
   function Get_Short_Help (Cmd : Command_Compile) return String;
   procedure Decode_Option (Cmd : in out Command_Compile;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res);
   procedure Perform_Action (Cmd : in out Command_Compile;
                             Args : Argument_List);

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

   function Get_Short_Help (Cmd : Command_Compile) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "-c [OPTS] FILEs -r UNIT [ARCH] [RUNOPTS]  "
        & "Compile, elaborate and run UNIT";
   end Get_Short_Help;

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

   procedure Perform_Action (Cmd : in out Command_Compile;
                             Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
      Elab_Arg : Natural;
      Run_Arg : Natural;
   begin
      begin
         Hooks.Compile_Init.all (False);

         Flags.Flag_Elaborate_With_Outdated := True;
         Flags.Flag_Only_Elab_Warnings := False;

         if Args'Length > 1 and then
           (Args (Args'First).all = "-r" or else Args (Args'First).all = "-e")
         then
            --  If there is no files, then load the work library.
            Libraries.Load_Work_Library (False);
            --  Also, load all libraries and files, so that every design unit
            --  is known.
            Load_All_Libraries_And_Files;
            Elab_Arg := Args'First + 1;
         else
            --  If there is at least one file, do not load the work library.
            Libraries.Load_Work_Library (True);
            Elab_Arg := Natural'Last;
            for I in Args'Range loop
               declare
                  Arg : constant String := Args (I).all;
                  Res : Iir_Design_File;
                  Design : Iir;
                  Next_Design : Iir;
               begin
                  if Arg = "-r" or else Arg = "-e" then
                     Elab_Arg := I + 1;
                     exit;
                  else
                     Res := Libraries.Load_File
                       (Name_Table.Get_Identifier (Arg));
                     if Errorout.Nbr_Errors > 0 then
                        raise Compilation_Error;
                     end if;

                     --  Put units into library.
                     Design := Get_First_Design_Unit (Res);
                     while not Is_Null (Design) loop
                        Next_Design := Get_Chain (Design);
                        Set_Chain (Design, Null_Iir);
                        Libraries.Add_Design_Unit_Into_Library (Design);
                        Design := Next_Design;
                     end loop;
                  end if;
               end;
            end loop;
            if Elab_Arg = Natural'Last then
               Libraries.Save_Work_Library;
               return;
            end if;
         end if;

         Hooks.Compile_Elab.all ("-c", Args (Elab_Arg .. Args'Last), Run_Arg);
      exception
         when Compilation_Error =>
            if Flag_Expect_Failure then
               return;
            else
               raise;
            end if;
      end;
      if Args (Elab_Arg - 1).all = "-r" then
         Hooks.Set_Run_Options (Args (Run_Arg .. Args'Last));
         Hooks.Run.all;
      else
         if Run_Arg <= Args'Last then
            Error_Msg_Option ("options after unit are ignored");
         end if;
      end if;
   end Perform_Action;

   --  Command -a
   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);
      use Types;
      Id : Name_Id;
      Design_File : Iir_Design_File;
      New_Design_File : Iir_Design_File;
      Unit : Iir;
      Next_Unit : Iir;
   begin
      Setup_Libraries (True);

      Hooks.Compile_Init.all (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 Errorout.Nbr_Errors > 0 then
            raise Compilation_Error;
         end if;

         if False then
            --  Speed up analysis: remove all previous designs.
            --  However, this is not in the LRM...
            Libraries.Purge_Design_File (Design_File);
         end if;

         if Design_File /= Null_Iir then
            Unit := Get_First_Design_Unit (Design_File);
            while Unit /= Null_Iir loop
               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);
                  New_Design_File := Get_Design_File (Unit);
               end if;

               Unit := Next_Unit;
            end loop;

            if Errorout.Nbr_Errors > 0 then
               raise Compilation_Error;
            end if;

            --  Do late analysis checks.
            Unit := Get_First_Design_Unit (New_Design_File);
            while Unit /= Null_Iir loop
               Sem.Sem_Analysis_Checks_List (Unit, Flags.Warn_Delayed_Checks);
               Unit := Get_Chain (Unit);
            end loop;

            if Errorout.Nbr_Errors > 0 then
               raise Compilation_Error;
            end if;
         end if;
      end loop;

      if Flag_Expect_Failure then
         raise Compilation_Error;
      end if;

      Libraries.Save_Work_Library;
   exception
      when Compilation_Error =>
         if Flag_Expect_Failure and Errorout.Nbr_Errors /= 0 then
            return;
         else
            raise;
         end if;
   end Perform_Action;

   --  Command -e
   type Command_Elab is new Command_Lib with null record;
   function Decode_Command (Cmd : Command_Elab; Name : String)
                           return Boolean;
   function Get_Short_Help (Cmd : Command_Elab) return String;
   procedure Decode_Option (Cmd : in out Command_Elab;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res);

   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 Decode_Option (Cmd : in out Command_Elab;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res)
   is
   begin
      if Option = "--expect-failure" then
         Flag_Expect_Failure := True;
         Res := Option_Ok;
      elsif Option = "-o" then
         if Arg'Length = 0 then
            Res := Option_Arg_Req;
         else
            --  Silently accepted.
            Res := Option_Arg;
         end if;
      --elsif Option'Length >= 4 and then Option (1 .. 4) = "-Wl," then
      --   Res := Option_Ok;
      else
         Decode_Option (Command_Lib (Cmd), Option, Arg, Res);
      end if;
   end Decode_Option;

   procedure Perform_Action (Cmd : in out Command_Elab;
                             Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
      Run_Arg : Natural;
   begin
      Hooks.Compile_Init.all (False);

      Libraries.Load_Work_Library (False);
      Flags.Flag_Elaborate_With_Outdated := False;
      Flags.Flag_Only_Elab_Warnings := True;

      Hooks.Compile_Elab.all ("-e", Args, Run_Arg);
      if Run_Arg <= Args'Last then
         Error_Msg_Option ("options after unit are ignored");
      end if;
      if Flag_Expect_Failure then
         raise Compilation_Error;
      end if;
   exception
      when Compilation_Error =>
         if Flag_Expect_Failure and then Errorout.Nbr_Errors > 0 then
            return;
         else
            raise;
         end if;
   end Perform_Action;

   --  Command dispconfig.
   type Command_Dispconfig is new Command_Lib 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 Errorout.Option_Error;
      end if;

      Put ("command line prefix (--PREFIX): ");
      if Prefix_Path = null then
         Put_Line ("(not set)");
      else
         Put_Line (Prefix_Path.all);
      end if;
      Setup_Libraries (False);

      Put ("environment prefix (GHDL_PREFIX): ");
      if Prefix_Env = null then
         Put_Line ("(not set)");
      else
         Put_Line (Prefix_Env.all);
      end if;

      Put_Line ("default prefix: " & Default_Pathes.Prefix);
      Put_Line ("actual prefix: " & Prefix_Path.all);
      Put_Line ("command_name: " & Ada.Command_Line.Command_Name);
      Put_Line ("default library pathes:");
      for I in 2 .. Get_Nbr_Pathes loop
         Put (' ');
         Put_Line (Name_Table.Image (Get_Path (I)));
      end loop;
   end Perform_Action;

   --  Command Make.
   type Command_Make is new Command_Comp with null record;
   function Decode_Command (Cmd : Command_Make; Name : String)
                           return Boolean;
   function Get_Short_Help (Cmd : Command_Make) return String;
   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 Perform_Action (Cmd : in out Command_Make; Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
      use Types;

      Files_List : Iir_List;
      File : Iir_Design_File;

      Next_Arg : Natural;
      Date : Date_Type;
      Unit : Iir_Design_Unit;
   begin
      Extract_Elab_Unit ("-m", Args, Next_Arg);
      Setup_Libraries (True);

      --  Create list of files.
      Files_List := Build_Dependence (Prim_Name, Sec_Name);

      Date := Get_Date (Libraries.Work_Library);
      for I in Natural loop
         File := Get_Nth_Element (Files_List, I);
         exit when File = Null_Iir;

         if Get_Library (File) = Libraries.Work_Library then
            --  Mark this file as analyzed.
            Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp);

            Unit := Get_First_Design_Unit (File);
            while Unit /= Null_Iir loop
               if Get_Date (Unit) = Date_Analyzed
                 or else Get_Date (Unit) in Date_Valid
               then
                  Date := Date + 1;
                  Set_Date (Unit, Date);
               end if;
               Unit := Get_Chain (Unit);
            end loop;
         end if;
      end loop;
      Set_Date (Libraries.Work_Library, Date);
      Libraries.Save_Work_Library;
   exception
      when Compilation_Error =>
         if Flag_Expect_Failure then
            return;
         else
            raise;
         end if;
   end Perform_Action;

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

   function Decode_Command (Cmd : Command_Gen_Makefile; Name : String)
                           return Boolean
   is
      pragma Unreferenced (Cmd);
   begin
      return Name = "--gen-makefile";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Gen_Makefile) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "--gen-makefile [OPTS] UNIT [ARCH]  Generate a Makefile for UNIT";
   end Get_Short_Help;

   function Is_Makeable_File (File : Iir_Design_File) return Boolean is
   begin
      if File = Std_Package.Std_Standard_File then
         return False;
      end if;
      return True;
   end Is_Makeable_File;

   procedure Perform_Action (Cmd : in out Command_Gen_Makefile;
                             Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
      use Types;
      use Ada.Text_IO;
      use Ada.Command_Line;
      use Name_Table;

      HT : constant Character := Ada.Characters.Latin_1.HT;
      Files_List : Iir_List;
      File : Iir_Design_File;

      Lib : Iir_Library_Declaration;
      Dir_Id : Name_Id;

      Next_Arg : Natural;
   begin
      Extract_Elab_Unit ("--gen-makefile", Args, Next_Arg);
      Setup_Libraries (True);
      Files_List := Build_Dependence (Prim_Name, Sec_Name);

      Put_Line ("# Makefile automatically generated by ghdl");
      Put ("# Version: ");
      Put (Version.Ghdl_Release);
      Put (" - ");
      if Version_String /= null then
         Put (Version_String.all);
      end if;
      New_Line;
      Put_Line ("# Command used to generate this makefile:");
      Put ("# ");
      Put (Command_Name);
      for I in 1 .. Argument_Count loop
         Put (' ');
         Put (Argument (I));
      end loop;
      New_Line;

      New_Line;

      Put ("GHDL=");
      Put_Line (Command_Name);

      --  Extract options for command line.
      Put ("GHDLFLAGS=");
      for I in 2 .. Argument_Count loop
         declare
            Arg : constant String := Argument (I);
         begin
            if Arg (1) = '-' then
               if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=")
                 or else (Arg'Length > 7 and then Arg (1 .. 7) = "--ieee=")
                 or else (Arg'Length > 6 and then Arg (1 .. 6) = "--std=")
                 or else (Arg'Length > 7 and then Arg (1 .. 7) = "--work=")
                 or else (Arg'Length > 2 and then Arg (1 .. 2) = "-P")
               then
                  Put (" ");
                  Put (Arg);
               end if;
            end if;
         end;
      end loop;
      New_Line;

      Put ("GHDLRUNFLAGS=");
      for I in Next_Arg .. Args'Last loop
         Put (' ');
         Put (Args (I).all);
      end loop;
      New_Line;
      New_Line;

      Put_Line ("# Default target : elaborate");
      Put_Line ("all : elab");
      New_Line;

      Put_Line ("# Elaborate target.  Almost useless");
      Put_Line ("elab : force");
      Put (HT & "$(GHDL) -c $(GHDLFLAGS) -e ");
      Put (Prim_Name.all);
      if Sec_Name /= null then
         Put (' ');
         Put (Sec_Name.all);
      end if;
      New_Line;
      New_Line;

      Put_Line ("# Run target");
      Put_Line ("run : force");
      Put (HT & "$(GHDL) -c $(GHDLFLAGS) -r ");
      Put (Prim_Name.all);
      if Sec_Name /= null then
         Put (' ');
         Put (Sec_Name.all);
      end if;
      Put (" $(GHDLRUNFLAGS)");
      New_Line;
      New_Line;

      Put_Line ("# Targets to analyze libraries");
      Put_Line ("init: force");
      for I in Natural loop
         File := Get_Nth_Element (Files_List, I);
         exit when File = Null_Iir;
         Dir_Id := Get_Design_File_Directory (File);
         if not Is_Makeable_File (File) then
            --  Builtin file.
            null;
         elsif Dir_Id /= Files_Map.Get_Home_Directory then
            --  Not locally built file.
            Put (HT & "# ");
            Put (Image (Dir_Id));
            Put (Image (Get_Design_File_Filename (File)));
            New_Line;
         else

            Put (HT & "$(GHDL) -a $(GHDLFLAGS)");
            Lib := Get_Library (File);
            if Lib /= Libraries.Work_Library then
               --  Overwrite some options.
               Put (" --work=");
               Put (Image (Get_Identifier (Lib)));
               Dir_Id := Get_Library_Directory (Lib);
               Put (" --workdir=");
               if Dir_Id = Libraries.Local_Directory then
                  Put (".");
               else
                  Put (Image (Dir_Id));
               end if;
            end if;
            Put (' ');
            Put (Image (Get_Design_File_Filename (File)));
            New_Line;
         end if;
      end loop;
      New_Line;

      Put_Line ("force:");
   end Perform_Action;

   procedure Register_Commands is
   begin
      Register_Command (new Command_Analyze);
      Register_Command (new Command_Elab);
      Register_Command (new Command_Run);
      Register_Command (new Command_Compile);
      Register_Command (new Command_Make);
      Register_Command (new Command_Gen_Makefile);
      Register_Command (new Command_Dispconfig);
   end Register_Commands;

end Ghdlcomp;