--  GHDL driver - commands invoking gcc.
--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
--
--  This program 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 of the License, or
--  (at your option) any later version.
--
--  This program 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 this program.  If not, see <gnu.org/licenses>.
with System;
with Ada.Command_Line; use Ada.Command_Line;
with Interfaces.C_Streams;
with GNAT.OS_Lib; use GNAT.OS_Lib;

with Types; use Types;
with Tables;
with Dyn_Tables;
with Files_Map;
with Libraries;
with Default_Paths;
with Flags;
with Simple_IO; use Simple_IO;
with Name_Table; use Name_Table;
with Vhdl.Std_Package;
with Vhdl.Nodes; use Vhdl.Nodes;
with Vhdl.Configuration;
with Options; use Options;
with Ghdlmain; use Ghdlmain;
with Ghdllocal; use Ghdllocal;
with Errorout;

package body Ghdldrv is
   --  Argument table for the tools.
   --  Each table low bound is 1 so that the length of a table is equal to
   --  the last bound.
   package Argument_Table_Pkg is new Dyn_Tables
     (Table_Component_Type => String_Access,
      Table_Index_Type => Integer,
      Table_Low_Bound => 1);
   use Argument_Table_Pkg;

   --  "-o" string.
   Dash_o : constant String_Access := new String'("-o");

   --  "-c" string.
   Dash_c : constant String_Access := new String'("-c");

   --  "-quiet" option.
   Dash_Quiet : constant String_Access := new String'("-quiet");

   --  "-auxbase" option.
   Dash_Auxbase : constant String_Access := new String'("-auxbase");

   --  "-fpic" option.
   Dash_Fpic : constant String_Access := new String'("-fpic");

   --  "-shared" string.
   Dash_Shared : constant String_Access := new String'("-shared");

   --  Elaboration mode.
   type Elab_Mode_Type is
     (--  Static elaboration (or pre-elaboration).
      Elab_Static,

      --  Dynamic elaboration: design is elaborated just before being run.
      Elab_Dynamic);

   type Command_Comp is abstract new Command_Lib with record
      --  Name of the tools used.
      Compiler_Cmd : String_Access := null;
      Post_Processor_Cmd : String_Access := null;
      Assembler_Cmd : String_Access := null;
      Linker_Cmd : String_Access := null;

      --  Path of the tools.
      Compiler_Path : String_Access;
      Post_Processor_Path : String_Access;
      Assembler_Path : String_Access;
      Linker_Path : String_Access;

      --  Set by the '-o' option: the output filename.  If the option is not
      --  present, then null.
      Output_File : String_Access;

      --  If set, do not assmble
      Flag_Asm : Boolean;

      --  If true, executed commands are displayed.
      Flag_Disp_Commands : Boolean;

      --  Flag not quiet
      Flag_Not_Quiet : Boolean;

      --  True if failure expected.
      Flag_Expect_Failure : Boolean;

      --  True if create a shared library.
      Flag_Shared : Boolean;

      --  Default elaboration mode is dynamic.
      Elab_Mode : Elab_Mode_Type := Elab_Dynamic;

      --  Arguments for tools.
      Compiler_Args : Argument_Table_Pkg.Instance;
      Postproc_Args : Argument_Table_Pkg.Instance;
      Assembler_Args : Argument_Table_Pkg.Instance;
      Linker_Args : Argument_Table_Pkg.Instance;
   end 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_State);

   procedure Disp_Long_Help (Cmd : Command_Comp);

   --  Display the program spawned in Flag_Disp_Commands is TRUE.
   --  Return the exit status.
   function My_Spawn_Status
     (Cmd : Command_Comp'Class; Program_Name : String; Args : Argument_List)
     return Integer is
   begin
      if Cmd.Flag_Disp_Commands then
         Put (Program_Name);
         for I in Args'Range loop
            Put (' ');
            Put (Args (I).all);
         end loop;
         New_Line;
      end if;
      return Spawn (Program_Name, Args);
   end My_Spawn_Status;

   --  Display the program spawned in Flag_Disp_Commands is TRUE.
   --  Raise COMPILE_ERROR in case of failure.
   procedure My_Spawn
     (Cmd : Command_Comp'Class; Program_Name : String; Args : Argument_List)
   is
      Status : Integer;
   begin
      Status := My_Spawn_Status (Cmd, Program_Name, Args);
      if Status = 0 then
         return;
      elsif Status = 1 then
         Error ("compilation error");
         raise Compile_Error;
      elsif Status > 127 then
         Error ("executable killed by a signal");
         raise Exec_Error;
      else
         Error ("exec error");
         raise Exec_Error;
      end if;
   end My_Spawn;

   --  Compile FILE with additional argument OPTIONSS.
   procedure Do_Compile (Cmd : Command_Comp'Class;
                         Options : Argument_List;
                         File : String;
                         In_Work : Boolean)
   is
      Obj_File : String_Access;
      Asm_File : String_Access;
      Aux_File : String_Access;
      Post_File : String_Access;

      --  Add backend specific options.
      procedure Add_Backend_Options
        (P : in out Natural; Args : in out Argument_List) is
      begin
         --  Add -fpic for gcc/llvm.
         if Default_Paths.Default_Pie then
            case Backend is
               when Backend_Gcc
                 | Backend_Llvm =>
                  P := P + 1;
                  Args (P) := Dash_Fpic;
               when Backend_Mcode =>
                  null;
            end case;
         end if;

         --  Add -quiet for gcc, add -c for llvm
         case Backend is
            when Backend_Gcc =>
               if not Cmd.Flag_Not_Quiet then
                  P := P + 1;
                  Args (P) := Dash_Quiet;
               end if;
               P := P + 1;
               Args (P) := Dash_Auxbase;
               P := P + 1;
               Args (P) := Aux_File;
            when Backend_Llvm =>
               P := P + 1;
               Args (P) := Dash_c;
            when Backend_Mcode =>
               null;
         end case;

         Args (P + 1) := Dash_o;
         case Backend is
            when Backend_Gcc =>
               Args (P + 2) := Asm_File;
            when Backend_Llvm
              | Backend_Mcode =>
               Args (P + 2) := Obj_File;
         end case;
      end Add_Backend_Options;

      Success : Boolean;
   begin
      --  Create post file.
      if Flag_Postprocess then
         Post_File := Append_Suffix (File, Post_Suffix, In_Work);
      end if;

      --  Create asm file and aux file for gcc.
      case Backend is
         when Backend_Gcc =>
            Asm_File := Append_Suffix (File, Asm_Suffix, In_Work);
            Aux_File := new String'(Get_Base_Name (File));
         when Backend_Llvm
           | Backend_Mcode =>
            null;
      end case;

      --  Create obj file (may not be used, but the condition isn't simple).
      Obj_File := Append_Suffix (File, Get_Object_Suffix.all, In_Work);

      --  Compile.
      declare
         P : Natural;
         Nbr_Args : constant Natural :=
           Last (Cmd.Compiler_Args) + Options'Length + 7;
         Args : Argument_List (1 .. Nbr_Args);
      begin
         P := 0;
         for I in First .. Last (Cmd.Compiler_Args) loop
            P := P + 1;
            Args (P) := Cmd.Compiler_Args.Table (I);
         end loop;
         for I in Options'Range loop
            P := P + 1;
            Args (P) := Options (I);
         end loop;

         if not Flag_Postprocess then
            --  Backend options and output
            Add_Backend_Options (P, Args);
         else
            --  Postprocessor output.
            Args (P + 1) := Dash_o;
            Args (P + 2) := Post_File;
         end if;

         --  Input file.
         Args (P + 3) := new String'(File);

         My_Spawn (Cmd, Cmd.Compiler_Path.all, Args (1 .. P + 3));
         Free (Args (P + 3));
      exception
         when Compile_Error =>
            --  Delete temporary file in case of error.
            Delete_File (Args (P + 2).all, Success);
            --  FIXME: delete object file too ?
            raise;
      end;

      --  Post-process.
      if Flag_Postprocess then
         declare
            P : Natural;
            Nbr_Args : constant Natural := Last (Cmd.Postproc_Args) + 5;
            Args : Argument_List (1 .. Nbr_Args);
         begin
            P := 0;
            for I in First .. Last (Cmd.Postproc_Args) loop
               P := P + 1;
               Args (P) := Cmd.Postproc_Args.Table (I);
            end loop;

            Add_Backend_Options (P, Args);

            --  Input file.
            Args (P + 3) := Post_File;

            My_Spawn (Cmd, Cmd.Post_Processor_Path.all, Args (1 .. P + 3));
         end;

         Free (Post_File);
      end if;

      --  Assemble.
      case Backend is
         when Backend_Gcc =>
            if Cmd.Flag_Expect_Failure then
               Delete_File (Asm_File.all, Success);
            elsif not Cmd.Flag_Asm then
               declare
                  P : Natural;
                  Nbr_Args : constant Natural := Last (Cmd.Assembler_Args) + 4;
                  Args : Argument_List (1 .. Nbr_Args);
                  Success : Boolean;
               begin
                  P := 0;
                  for I in First .. Last (Cmd.Assembler_Args) loop
                     P := P + 1;
                     Args (P) := Cmd.Assembler_Args.Table (I);
                  end loop;

                  Args (P + 1) := Dash_o;
                  Args (P + 2) := Obj_File;
                  Args (P + 3) := Asm_File;
                  My_Spawn (Cmd, Cmd.Assembler_Path.all, Args (1 .. P + 3));
                  Delete_File (Asm_File.all, Success);
               end;
            end if;
         when Backend_Mcode
           | Backend_Llvm =>
            null;
      end case;

      Free (Asm_File);
      Free (Obj_File);
      Free (Aux_File);
   end Do_Compile;

   --  Table of files to be linked.
   package Filelist is new Tables
     (Table_Component_Type => String_Access,
      Table_Index_Type => Natural,
      Table_Low_Bound => 1,
      Table_Initial => 16);

   Link_Obj_Suffix : String_Access;

   --  Read a list of files from file FILENAME.
   --  Lines starting with a '#' are ignored (comments)
   --  Lines starting with a '>' are directory lines
   --  If first character of a line is a '@', it is replaced with
   --    the lib_prefix_path.
   --  If TO_OBJ is true, then each file is converted to an object file name
   --   (suffix is replaced by the object file extension).
   procedure Add_File_List (Filename : String; To_Obj : Boolean)
   is
      use Interfaces.C_Streams;
      use System;

      --  Replace the first '@' with the machine path.
      function Substitute (Str : String) return String
      is
      begin
         for I in Str'Range loop
            if Str (I) = '@' then
               return Str (Str'First .. I - 1)
                 & Get_Machine_Path_Prefix
                 & Str (I + 1 .. Str'Last);
            end if;
         end loop;
         return Str;
      end Substitute;

      Dir : String (1 .. max_path_len);
      Dir_Len : Natural;
      Line : String (1 .. max_path_len);
      Stream : Interfaces.C_Streams.FILEs;
      Mode : constant String := "rt" & Ghdllocal.Nul;
      L : Natural;
      File : String_Access;
   begin
      Line (1 .. Filename'Length) := Filename;
      Line (Filename'Length + 1) := Ghdllocal.Nul;
      Stream := fopen (Line'Address, Mode'Address);
      if Stream = NULL_Stream then
         Error ("cannot open " & Filename);
         raise Compile_Error;
      end if;
      Dir_Len := 0;
      loop
         exit when fgets (Line'Address, Line'Length, Stream) = NULL_Stream;
         if Line (1) /= '#' then
            --  Compute string length.
            L := 0;
            while Line (L + 1) /= Ghdllocal.Nul loop
               L := L + 1;
            end loop;

            --  Remove trailing NL.
            while L > 0 and then (Line (L) = ASCII.LF or Line (L) = ASCII.CR)
            loop
               L := L - 1;
            end loop;

            if Line (1) = '>' then
               Dir_Len := L - 1;
               Dir (1 .. Dir_Len) := Line (2 .. L);
            elsif Line (1) = '+' then
               File := new String'(Line (2 .. L));
               Filelist.Append (File);
            else
               if To_Obj then
                  File := new String'(Dir (1 .. Dir_Len)
                                      & Get_Base_Name (Line (1 .. L))
                                      & Link_Obj_Suffix.all);
               else
                  File := new String'(Substitute (Line (1 .. L)));
               end if;

               Filelist.Append (File);

               Dir_Len := 0;
            end if;
         end if;
      end loop;
      if fclose (Stream) /= 0 then
         Error ("cannot close " & Filename);
      end if;
   end Add_File_List;

   function Get_Object_Filename (File : Iir_Design_File) return String
   is
      Dir : Name_Id;
      Name : Name_Id;
   begin
      Dir := Get_Library_Directory (Get_Library (File));
      Name := Get_Design_File_Filename (File);
      return Image (Dir) & Get_Base_Name (Image (Name))
        & Get_Object_Suffix.all;
   end Get_Object_Filename;

   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;

   --  Set the compiler command according to the configuration (and switches).
   procedure Set_Tools_Name (Cmd : in out Command_Comp'Class) is
   begin
      --  Set tools name.
      if Cmd.Compiler_Cmd = null then
         if Flag_Postprocess then
            Cmd.Compiler_Cmd := new String'(Default_Paths.Compiler_Debug);
         else
            case Backend is
               when Backend_Gcc =>
                  Cmd.Compiler_Cmd := new String'(Default_Paths.Compiler_Gcc);
               when Backend_Mcode =>
                  Cmd.Compiler_Cmd :=
                    new String'(Default_Paths.Compiler_Mcode);
               when Backend_Llvm =>
                  Cmd.Compiler_Cmd := new String'(Default_Paths.Compiler_Llvm);
            end case;
         end if;
      end if;
      if Cmd.Post_Processor_Cmd = null then
         Cmd.Post_Processor_Cmd := new String'(Default_Paths.Post_Processor);
      end if;
      if Cmd.Assembler_Cmd = null then
         Cmd.Assembler_Cmd := new String'("as");
      end if;
      if Cmd.Linker_Cmd = null then
         Cmd.Linker_Cmd := new String'("cc");
      end if;
   end Set_Tools_Name;

   function Locate_Exec_Tool (Toolname : String) return String_Access is
   begin
      if Is_Absolute_Path (Toolname) then
         if Is_Executable_File (Toolname) then
            return new String'(Toolname);
         end if;
      else
         --  Try from install prefix.  This is used at least with gcc when
         --  ghdl1 is installed in a libexec subdirectory, and also during
         --  development.
         if Exec_Prefix /= null then
            declare
               Path : constant String :=
                 Exec_Prefix.all & Directory_Separator & Toolname;
            begin
               if Is_Executable_File (Path) then
                  return new String'(Path);
               end if;
            end;
         end if;

         --  Try from install prefix / bin.  This is used at least for
         --  ghdl1-llvm.
         if Exec_Prefix /= null then
            declare
               Path : constant String :=
                 Exec_Prefix.all & Directory_Separator
                 & "bin" & Directory_Separator & Toolname;
            begin
               if Is_Executable_File (Path) then
                  return new String'(Path);
               end if;
            end;
         end if;

         --  Try configured prefix.
         declare
            Path : constant String :=
              Default_Paths.Install_Prefix & Directory_Separator & Toolname;
         begin
            if Is_Executable_File (Path) then
               return new String'(Path);
            end if;
         end;
      end if;

      --  Search the basename on path.
      declare
         Pos : constant Natural := Get_Basename_Pos (Toolname);
      begin
         return Locate_Exec_On_Path (Toolname (Pos + 1 .. Toolname'Last));
      end;
   end Locate_Exec_Tool;

   procedure Locate_Tools (Cmd : in out Command_Comp'Class) is
   begin
      --  Compiler.
      Cmd.Compiler_Path := Locate_Exec_Tool (Cmd.Compiler_Cmd.all);
      if Cmd.Compiler_Path = null then
         Tool_Not_Found (Cmd.Compiler_Cmd.all);
      end if;

      --  Postprocessor.
      if Flag_Postprocess then
         Cmd.Post_Processor_Path :=
           Locate_Exec_Tool (Cmd.Post_Processor_Cmd.all);
         if Cmd.Post_Processor_Path = null then
            Tool_Not_Found (Cmd.Post_Processor_Cmd.all);
         end if;
      end if;

      --  Assembler.
      case Backend is
         when Backend_Gcc =>
            Cmd.Assembler_Path := Locate_Exec_On_Path (Cmd.Assembler_Cmd.all);
            if Cmd.Assembler_Path = null and not Cmd.Flag_Asm then
               Tool_Not_Found (Cmd.Assembler_Cmd.all);
            end if;
         when Backend_Llvm
           | Backend_Mcode =>
            null;
      end case;

      --  Linker.
      Cmd.Linker_Path := Locate_Exec_On_Path (Cmd.Linker_Cmd.all);
      if Cmd.Linker_Path = null then
         Tool_Not_Found (Cmd.Linker_Cmd.all);
      end if;
   end Locate_Tools;

   procedure Setup_Compiler (Cmd : in out Command_Comp'Class; Load : Boolean)
   is
      use Libraries;
   begin
      Set_Tools_Name (Cmd);
      if not Setup_Libraries (Load) then
         raise Option_Error;
      end if;
      Locate_Tools (Cmd);
      for I in 2 .. Get_Nbr_Paths loop
         Add_Argument (Cmd.Compiler_Args,
                       new String'("-P" & Image (Get_Path (I))));
      end loop;
   end Setup_Compiler;

   procedure Init (Cmd : in out Command_Comp) is
   begin
      Init (Command_Lib (Cmd));

      --  Init options.
      Cmd.Flag_Not_Quiet := False;
      Cmd.Flag_Disp_Commands := False;
      Cmd.Flag_Asm := False;
      Cmd.Flag_Expect_Failure := False;
      Cmd.Output_File := null;
      Cmd.Flag_Shared := False;

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

   procedure Decode_Option (Cmd : in out Command_Comp;
                            Option : String;
                            Arg : String;
                            Res : out Option_State)
   is
      Opt : constant String (1 .. Option'Length) := Option;
      Str : String_Access;
   begin
      Res := Option_Unknown;
      if Opt = "-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;
         Cmd.Flag_Disp_Commands := True;
         Res := Option_Ok;
      elsif Opt'Length > 8 and then Opt (1 .. 8) = "--GHDL1=" then
         Cmd.Compiler_Cmd := new String'(Opt (9 .. Opt'Last));
         Res := Option_Ok;
      elsif Opt'Length > 5 and then Opt (1 .. 5) = "--AS=" then
         Cmd.Assembler_Cmd := new String'(Opt (6 .. Opt'Last));
         Res := Option_Ok;
      elsif Opt'Length > 7 and then Opt (1 .. 7) = "--LINK=" then
         Cmd.Linker_Cmd := new String'(Opt (8 .. Opt'Last));
         Res := Option_Ok;
      elsif Opt = "-S" then
         Cmd.Flag_Asm := True;
         Res := Option_Ok;
      elsif Opt = "--post" then
         Flag_Postprocess := True;
         Res := Option_Ok;
      elsif Opt = "-o" then
         if Arg'Length = 0 then
            Res := Option_Arg_Req;
         else
            Cmd.Output_File := new String'(Arg);
            Res := Option_Arg;
         end if;
      elsif Opt = "-shared" then
         Cmd.Flag_Shared := True;
         Res := Option_Ok;
      elsif Opt = "-m32" then
         Add_Argument (Cmd.Compiler_Args, new String'("-m32"));
         Add_Argument (Cmd.Assembler_Args, new String'("--32"));
         Add_Argument (Cmd.Linker_Args, new String'("-m32"));
         Decode_Option (Command_Lib (Cmd), Opt, Arg, Res);
      elsif Opt'Length > 4
        and then Opt (2) = 'W' and then Opt (4) = ','
      then
         if Opt (3) = 'c' then
            Add_Arguments (Cmd.Compiler_Args, Opt);
         elsif Opt (3) = 'a' then
            Add_Arguments (Cmd.Assembler_Args, Opt);
         elsif Opt (3) = 'p' then
            Add_Arguments (Cmd.Postproc_Args, Opt);
         elsif Opt (3) = 'l' then
            Add_Arguments (Cmd.Linker_Args, Opt);
         else
            Error ("unknown tool name in '-W" & Opt (3) & ",' option");
            Res := Option_Err;
            return;
         end if;
         Res := Option_Ok;
      elsif Opt'Length >= 2 and then Opt (2) = 'g' then
         --  Debugging option.
         Str := new String'(Opt);
         Add_Argument (Cmd.Compiler_Args, Str);
         Add_Argument (Cmd.Linker_Args, Str);
         Res := Option_Ok;
      elsif Opt = "-Q" then
         Cmd.Flag_Not_Quiet := True;
         Res := Option_Ok;
      elsif Opt = "--expect-failure" then
         Add_Argument (Cmd.Compiler_Args, new String'(Opt));
         Cmd.Flag_Expect_Failure := True;
         Res := Option_Ok;
      elsif Opt = "-C" then
         --  Translate -C into --mb-comments, as gcc already has a definition
         --  for -C.  Done before Flags.Parse_Option.
         Add_Argument (Cmd.Compiler_Args, new String'("--mb-comments"));
         Res := Option_Ok;
      elsif Opt = "--pre-elab" then
         Cmd.Elab_Mode := Elab_Static;
         Res := Option_Ok;
      elsif Opt = "--dyn-elab" then
         Cmd.Elab_Mode := Elab_Dynamic;
         Res := Option_Ok;
      elsif Opt'Length > 18
        and then Opt (1 .. 18) = "--time-resolution="
      then
         Error ("option --time-resolution not supported by back-end");
         Res := Option_Err;
         return;
      elsif Opt = "--ieee=synopsys" or else Opt = "--ieee=none" then
         --  Automatically translate the option.
         if Backend = Backend_Gcc then
            Add_Argument (Cmd.Compiler_Args, new String'("--ghdl-fsynopsys"));
         else
            Add_Argument (Cmd.Compiler_Args, new String'("-fsynopsys"));
         end if;
         Flags.Flag_Synopsys := True;
         Res := Option_Ok;
      else
         Res := Options.Parse_Option (Opt);
         if Res = Option_Ok then
            if Opt'Length > 2 and then Opt (1 .. 2) = "-P" then
               --  Discard -Pxxx switches, as they are already added to
               --  compiler_args.
               null;
            else
               if Backend = Backend_Gcc then
                  --  Prefix options for gcc so that lang.opt does need to be
                  --  updated when a new option is added.
                  Str := new String'("--ghdl" & Opt);
               else
                  Str := new String'(Opt);
               end if;
               Add_Argument (Cmd.Compiler_Args, Str);
            end if;
         elsif Res = Option_Unknown then
            if Opt'Length >= 2
              and then (Opt (2) = 'O' or Opt (2) = 'f')
            then
               --  Optimization option supported by gcc/llvm.
               --  This is put after Flags.Parse_Option, since it may catch
               --  -fxxx options.
               Add_Argument (Cmd.Compiler_Args, new String'(Opt));
               Res := Option_Ok;
            else
               Decode_Option (Command_Lib (Cmd), Opt, Arg, Res);
            end if;
         end if;
      end if;
   end Decode_Option;

   procedure Disp_Long_Help (Cmd : Command_Comp) is
   begin
      Disp_Long_Help (Command_Lib (Cmd));
      Put_Line (" -v");
      Put_Line ("   Be verbose");
      Put_Line (" --GHDL1=PATH");
      Put_Line ("   Set the path of the ghdl1 compiler");
      Put_Line (" --AS=as");
      Put_Line ("   Use as for the assembler");
      Put_Line (" --LINK=gcc");
      Put_Line ("   Use gcc for the linker driver");
      Put_Line (" -S");
      Put_Line ("   Do not assemble");
      Put_Line (" -o FILE");
      Put_Line ("   Set the name of the output file");
   -- Put_Line (" -m32           Generate 32bit code on 64bit machines");
      Put_Line (" -WX,OPTION");
      Put_Line ("   Pass OPTION to X, where X is one of");
      Put_Line ("  c: compiler, a: assembler, l: linker");
      Put_Line (" -g[XX]");
      Put_Line ("   Pass debugging option to the compiler");
      Put_Line (" -O[XX]/-f[XX]");
      Put_Line ("   Pass optimization option to the compiler");
      Put_Line (" -Q");
      Put_Line ("   Do not add -quiet option to compiler");
      Put_Line (" --expect-failure");
      Put_Line ("   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 = "disp-config"
        or else Name = "--disp-config"
        or else Name = "dispconfig"
        or else Name = "--dispconfig";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Dispconfig) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "disp-config"
        & ASCII.LF & "  Display tools path"
        & ASCII.LF & "  aliases: --disp-config, dispconfig, --dispconfig";
   end Get_Short_Help;

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

      Set_Tools_Name (Cmd);
      Put_Line ("Paths at configuration:");
      Put ("compiler command: ");
      Put_Line (Cmd.Compiler_Cmd.all);
      if Flag_Postprocess then
         Put ("post-processor command: ");
         Put_Line (Cmd.Post_Processor_Cmd.all);
      end if;
      case Backend is
         when Backend_Gcc =>
            Put ("assembler command: ");
            Put_Line (Cmd.Assembler_Cmd.all);
         when Backend_Llvm
           | Backend_Mcode =>
            null;
      end case;
      Put ("linker command: ");
      Put_Line (Cmd.Linker_Cmd.all);
      Put_Line ("default lib prefix: " & Default_Paths.Lib_Prefix);

      New_Line;

      Disp_Config_Prefixes;

      Locate_Tools (Cmd);
      Put ("compiler path: ");
      Put_Line (Cmd.Compiler_Path.all);
      if Flag_Postprocess then
         Put ("post-processor path: ");
         Put_Line (Cmd.Post_Processor_Path.all);
      end if;
      case Backend is
         when Backend_Gcc =>
            Put ("assembler path: ");
            Put_Line (Cmd.Assembler_Path.all);
         when Backend_Llvm
           | Backend_Mcode =>
            null;
      end case;
      Put ("linker path: ");
      Put_Line (Cmd.Linker_Path.all);

      New_Line;

      Put_Line ("default library paths:");
      for I in 2 .. Get_Nbr_Paths loop
         Put (' ');
         Put_Line (Image (Get_Path (I)));
      end loop;
   end Perform_Action;

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

   function Decode_Command (Cmd : Command_Bootstrap; Name : String)
                           return Boolean
   is
      pragma Unreferenced (Cmd);
   begin
      return Name = "bootstrap-std"
        or else Name = "--bootstrap-standard";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Bootstrap) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "bootstrap-std"
        & ASCII.LF & "  (internal) Compile std.standard"
        & ASCII.LF & "  alias: --bootstrap-standard";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_Bootstrap;
                             Args : Argument_List)
   is
      Opt : Argument_List (1 .. 1);
   begin
      if Args'Length /= 0 then
         Error ("no file allowed for --bootstrap-standard");
         raise Option_Error;
      end if;

      Setup_Compiler (Cmd, False);

      Opt (1) := new String'("--compile-standard");
      Do_Compile (Cmd, Opt, "std_standard.vhdl", True);
   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 = "analyze"
        or else Name = "-a"
        or else Name = "analyse";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Analyze) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "analyze [OPTS] FILEs"
        & ASCII.LF & "  Analyze one or multiple VHDL files"
        & ASCII.LF & "  aliases: -a, analyse";
   end Get_Short_Help;

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

      Expect_Filenames (Args);

      Setup_Compiler (Cmd, False);

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

   --  Elaboration.

   Library_Id : Name_Id;
   Primary_Id : Name_Id;
   Secondary_Id : Name_Id;
   Base_Name : String_Access;
   Elab_Name : String_Access;
   Filelist_Name : String_Access;
   Unit_Name : String_Access;

   procedure Set_Elab_Units (Cmd : in out Command_Comp'Class;
                             Cmd_Name : String;
                             Args : Argument_List;
                             Run_Arg : out Natural)
   is
      function Library_Prefix_Image (Id : Name_Id) return String is
      begin
         if Id = Null_Identifier then
            return "";
         else
            return Image (Id) & '.';
         end if;
      end Library_Prefix_Image;

      function Arch_Suffix_Image (Id : Name_Id) return String is
      begin
         if Id = Null_Identifier then
            return "";
         else
            return '(' & Image (Id) & ')';
         end if;
      end Arch_Suffix_Image;
   begin
      Library_Id := Null_Identifier;
      Extract_Elab_Unit (Cmd_Name, Args, Run_Arg,
                         Library_Id, Primary_Id, Secondary_Id);
      if Secondary_Id = Null_Identifier then
         Base_Name := new String'(Image (Primary_Id));
      else
         Base_Name := new String'(Image (Primary_Id)
                                    & '-' & Image (Secondary_Id));
      end if;

      Unit_Name := new String'(Library_Prefix_Image (Library_Id)
                                 & Image (Primary_Id)
                                 & Arch_Suffix_Image (Secondary_Id));
      Filelist_Name := null;

      --  Choose a default name for the executable.
      if Cmd.Output_File = null then
         if Cmd.Flag_Shared then
            Cmd.Output_File := new String'
              (Base_Name.all & Default_Paths.Shared_Library_Extension);
         else
            Cmd.Output_File := new String'(Base_Name.all);
         end if;
      end if;

      --  Set a name for the elaboration files.  Use the basename of the
      --  output file, so that parallel builds with different output files
      --  are allowed.
      declare
         Dir_Pos : constant Natural := Get_Basename_Pos (Cmd.Output_File.all);
      begin
         Elab_Name := new String'
           (Cmd.Output_File (Cmd.Output_File'First .. Dir_Pos)
              & Elab_Prefix
              & Cmd.Output_File (Dir_Pos + 1 .. Cmd.Output_File'Last));
      end;
   end Set_Elab_Units;

   procedure Set_Elab_Units (Cmd : in out Command_Comp'Class;
                             Cmd_Name : String;
                             Args : Argument_List)
   is
      Next_Arg : Natural;
   begin
      Set_Elab_Units (Cmd, 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 (Cmd : Command_Comp'Class)
   is
      Comp_List : Argument_List (1 .. 4);
      Elab_Cmd : String_Access;
   begin
      Filelist_Name := new String'(Elab_Name.all & List_Suffix);

      case Cmd.Elab_Mode is
         when Elab_Static =>
            Elab_Cmd := new String'("--pre-elab");
         when Elab_Dynamic =>
            Elab_Cmd := new String'("--elab");
      end case;
      Comp_List (1) := Elab_Cmd;
      Comp_List (2) := Unit_Name;
      Comp_List (3) := new String'("-l");
      Comp_List (4) := Filelist_Name;
      Do_Compile (Cmd, Comp_List, Elab_Name.all, False);
      Free (Comp_List (3));
      Free (Comp_List (1));
   end Bind;

   procedure Bind_Anaelab (Cmd : Command_Comp'Class; Files : Argument_List)
   is
      Comp_List : Argument_List (1 .. Files'Length + 2);
      Index : Natural;
   begin
      Comp_List (1) := new String'("--anaelab");
      Comp_List (2) := Unit_Name;
      Index := 3;
      for I in Files'Range loop
         Comp_List (Index) := new String'("--ghdl-source=" & Files (I).all);
         Index := Index + 1;
      end loop;
      Do_Compile (Cmd, Comp_List, Elab_Name.all, False);
      Free (Comp_List (1));
      for I in 3 .. Comp_List'Last loop
         Free (Comp_List (I));
      end loop;
   end Bind_Anaelab;

   --  Add PFX.lst from the install lib directory.
   procedure Add_Lib_File_List (Pfx : String) is
   begin
      Add_File_List (Get_Machine_Path_Prefix & Directory_Separator
                       & Pfx & List_Suffix, False);
   end Add_Lib_File_List;

   procedure Link
     (Cmd : Command_Comp'Class; Add_Std : Boolean; Disp_Only : Boolean)
   is
      Last_File : Natural;
   begin
      Link_Obj_Suffix := Get_Object_Suffix;

      --  read files list
      if Filelist_Name /= null then
         Add_File_List (Filelist_Name.all, True);
      end if;
      Last_File := Filelist.Last;
      Add_Lib_File_List ("grt");
      if Cmd.Flag_Shared then
         Add_Lib_File_List ("grt-shared");
      else
         Add_Lib_File_List ("grt-exec");
      end if;

      --  call the linker
      declare
         P : Natural;
         Nbr_Args : constant Natural :=
           Last (Cmd.Linker_Args) + Filelist.Last + 5;
         Args : Argument_List (1 .. Nbr_Args);
         Obj_File : String_Access;
         Std_File : String_Access;
      begin
         Obj_File := Append_Suffix (Elab_Name.all, Link_Obj_Suffix.all, False);
         P := 0;
         Args (P + 1) := Dash_o;
         Args (P + 2) := Cmd.Output_File;
         Args (P + 3) := Obj_File;
         P := P + 3;
         if Cmd.Flag_Shared then
            P := P + 1;
            Args (P) := Dash_Shared;
         end if;
         if Add_Std then
            Std_File := new
              String'(Get_Machine_Path_Prefix & Directory_Separator
                      & "std" & Directory_Separator
                      & Get_Version_Path & Directory_Separator
                      & "std_standard" & Link_Obj_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 (Cmd.Linker_Args) loop
            P := P + 1;
            Args (P) := Cmd.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 (Cmd, Cmd.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 = "elaborate"
        or else Name = "-e";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Elab) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "elaborate [OPTS] UNIT [ARCH]"
        & ASCII.LF & "  Elaborate design UNIT"
        & ASCII.LF & "  alias: -e";
   end Get_Short_Help;

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

      Bind (Cmd);
      if not Cmd.Flag_Expect_Failure then
         Link (Cmd, 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 = "run"
        or else Name = "-r";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Run) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "run UNIT [ARCH] [RUNOPTS]"
        & ASCII.LF & "  Run design UNIT"
        & ASCII.LF & "  alias: -r";
   end Get_Short_Help;

   procedure Run_Design
     (Cmd : Command_Comp'Class; Exec : String_Access; Args : Argument_List)
   is
      Status : Integer;
   begin
      if Is_Absolute_Path (Exec.all) then
         Status := My_Spawn_Status (Cmd, Exec.all, Args);
      else
         Status := My_Spawn_Status
           (Cmd, '.' & Directory_Separator & Exec.all, Args);
      end if;
      Set_Exit_Status (Exit_Status (Status));
   end Run_Design;

   procedure Perform_Action (Cmd : in out Command_Run; Args : Argument_List)
   is
      Suffix : constant String_Access := Get_Executable_Suffix;
      Lib_Id : Name_Id;
      Prim_Id : Name_Id;
      Sec_Id : Name_Id;
      Opt_Arg : Natural;
   begin
      Extract_Elab_Unit ("-r", Args, Opt_Arg, Lib_Id, Prim_Id, Sec_Id);
      if Sec_Id = Null_Identifier then
         Base_Name := new String'
           (Image (Prim_Id) & Suffix.all);
      else
         Base_Name := new String'
           (Image (Prim_Id) & '-' & Image (Sec_Id) & Suffix.all);
      end if;
      if not Is_Regular_File (Base_Name.all & Nul) then
         Error ("file '" & Base_Name.all & "' does not exist");
         Error ("Please elaborate your design.");
         raise Exec_Error;
      end if;
      Run_Design (Cmd, Base_Name, 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"
        or else 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] [RUNOPTS]"
        & ASCII.LF & "  Elaborate and run design UNIT"
        & ASCII.LF & "  alias: --elab-run";
   end Get_Short_Help;

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

      Bind (Cmd);
      if Cmd.Flag_Expect_Failure then
         Delete_File (Filelist_Name.all, Success);
      else
         Link (Cmd, Add_Std => True, Disp_Only => False);
         Delete_File (Filelist_Name.all, Success);
         Run_Design (Cmd, Cmd.Output_File, 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"
        or else Name = "--bind";
   end Decode_Command;

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

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

      Bind (Cmd);
   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"
        or else Name = "--link";
   end Decode_Command;

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

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

      Filelist_Name := new String'(Elab_Name.all & List_Suffix);
      Link (Cmd, 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"
        or else 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]"
        & ASCII.LF & "  List objects file to link UNIT"
        & ASCII.LF & "  alias: --list-link";
   end Get_Short_Help;

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

      Filelist_Name := new String'(Elab_Name.all & List_Suffix);
      Link (Cmd, 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_State);

   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 = "compile"
        or else Name = "-c";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Anaelab) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "compile [OPTS] FILEs -e UNIT [ARCH]"
        & ASCII.LF & "  Generate whole sequence to elaborate "
        & "design UNIT from FILEs"
        & ASCII.LF & "  alias: -c";
   end Get_Short_Help;

   procedure Decode_Option (Cmd : in out Command_Anaelab;
                            Option : String;
                            Arg : String;
                            Res : out Option_State) 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
      Elab_Index : Integer;
      Error : Boolean;
   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
         --  No elaboration.
         Analyze_Files (Args, True, Error);
         if Error then
            raise Errorout.Compilation_Error;
         end if;
      else
         Set_Elab_Units (Cmd, "-c", Args (Elab_Index + 1 .. Args'Last));
         Setup_Compiler (Cmd, False);

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

   --  Command Make.
   type Command_Make is new Command_Comp with record
      -- Bind only; don't link
      Flag_Bind_Only : Boolean;

      --  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_State);

   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 = "make"
        or else Name = "-m";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Make) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "make [OPTS] UNIT [ARCH]"
        & ASCII.LF & "  Make design UNIT"
        & ASCII.LF & "  alias: -m";
   end Get_Short_Help;

   procedure Disp_Long_Help (Cmd : Command_Make)
   is
   begin
      Disp_Long_Help (Command_Comp (Cmd));
      Put_Line (" -b" & ASCII.LF & "  Bind only; don't link");
      Put_Line (" -f" & ASCII.LF & "  Force recompilation of work units");
      Put_Line (" -Mu" & ASCII.LF & "  Disp unit dependences (human format)");
   end Disp_Long_Help;

   procedure Init (Cmd : in out Command_Make) is
   begin
      Init (Command_Comp (Cmd));
      Cmd.Flag_Bind_Only := False;
      Cmd.Flag_Depend_Unit := False;
      Cmd.Flag_Force := False;
   end Init;

   procedure Decode_Option (Cmd : in out Command_Make;
                            Option : String;
                            Arg : String;
                            Res : out Option_State) is
   begin
      if Option = "-b" then
         Cmd.Flag_Bind_Only := True;
         Res := Option_Ok;
      elsif Option = "-Mu" then
         Cmd.Flag_Depend_Unit := True;
         Res := Option_Ok;
      elsif Option = "-f" then
         Cmd.Flag_Force := True;
         Res := Option_Ok;
      else
         Decode_Option (Command_Comp (Cmd), Option, Arg, Res);
      end if;
   end Decode_Option;

   Last_Stamp : OS_Time;
   Last_Stamp_File : Iir;

   function Missing_Object_File (Design_File : Iir_Design_File) return Boolean
   is
      Name : constant Name_Id := Get_Design_File_Filename (Design_File);
      Obj_Pathname : constant String := Get_Object_Filename (Design_File);
      Stamp : OS_Time;
   begin
      Stamp := File_Time_Stamp (Obj_Pathname);

      --  If the object file does not exist, recompile the file.
      if Stamp = Invalid_Time then
         if Flag_Verbose then
            Put_Line ("no object file for " & Image (Name));
         end if;
         return True;
      end if;

      --  Keep the time stamp of the most recently analyzed unit.
      if Last_Stamp = Invalid_Time or else Stamp > Last_Stamp then
         Last_Stamp := Stamp;
         Last_Stamp_File := Design_File;
      end if;

      return False;
   end Missing_Object_File;

   procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List)
   is
      use Vhdl.Configuration;

      File : Iir_Design_File;
      Unit : Iir;
      Lib : Iir_Library_Declaration;
      In_Work : Boolean;

      Files_List : Iir_List;
      Files_It : List_Iterator;

      --  Set when a design file has been compiled.
      Has_Compiled : Boolean;

      Need_Analyze : Boolean;

      Need_Elaboration : Boolean;

      Stamp : OS_Time;
      File_Id : Name_Id;

      Nil_Args : Argument_List (2 .. 1);
      Success : Boolean;
   begin
      Set_Elab_Units (Cmd, "-m", Args);
      Setup_Compiler (Cmd, True);

      --  Create list of files.
      Files_List := Build_Dependence (Library_Id, Primary_Id, Secondary_Id);

      if Errorout.Nbr_Errors /= 0 then
         raise Errorout.Compilation_Error;
      end if;

      if Cmd.Flag_Depend_Unit then
         Put_Line ("Units analysis order:");
         for I in Design_Units.First .. Design_Units.Last loop
            Unit := Design_Units.Table (I);
            Put ("  ");
            Disp_Library_Unit (Get_Library_Unit (Unit));
            New_Line;
--             Put (" file: ");
--             File := Get_Design_File (Unit);
--             Put_Line (Image (Get_Design_File_Filename (File)));
         end loop;
      end if;
      if Cmd.Flag_Depend_Unit then
         Put_Line ("File analysis order:");
         Files_It := List_Iterate (Files_List);
         while Is_Valid (Files_It) loop
            Put ("  ");
            File := Get_Element (Files_It);
            Put (Image (Get_Design_File_Filename (File)));
            if Flag_Verbose then
               Put_Line (":");
               declare
                  Dep_List : constant Iir_List :=
                    Get_File_Dependence_List (File);
                  Dep_It : List_Iterator;
                  Dep_File : Iir;
               begin
                  Dep_It := List_Iterate_Safe (Dep_List);
                  while Is_Valid (Dep_It) loop
                     Put ("    ");
                     Dep_File := Get_Element (Dep_It);
                     Put_Line (Image (Get_Design_File_Filename (Dep_File)));
                     Next (Dep_It);
                  end loop;
               end;
            else
               New_Line;
            end if;
            Next (Files_It);
         end loop;
      end if;

      Has_Compiled := False;
      Last_Stamp := Invalid_Time;

      Files_It := List_Iterate (Files_List);
      while Is_Valid (Files_It) loop
         File := Get_Element (Files_It);

         if File = Vhdl.Std_Package.Std_Standard_File then
            Need_Analyze := False;
         elsif Missing_Object_File (File)
           or else Source_File_Modified (File)
           or else Is_File_Outdated (File)
         then
            Need_Analyze := True;
         else
            Need_Analyze := False;
         end if;

         Lib := Get_Library (File);
         In_Work := Lib = Libraries.Work_Library;

         if Need_Analyze or else (Cmd.Flag_Force and In_Work) then
            File_Id := Get_Design_File_Filename (File);
            if not Flag_Verbose then
               Put ("analyze ");
               Put (Image (File_Id));
               --Disp_Library_Unit (Get_Library_Unit (Unit));
               New_Line;
            end if;

            if In_Work then
               Do_Compile (Cmd, Nil_Args, Image (File_Id), True);
            else
               declare
                  use Libraries;
                  Lib_Args : Argument_List (1 .. 2);
                  Prev_Workdir : Name_Id;
               begin
                  Prev_Workdir := Work_Directory;

                  --  Must be set, since used to build the object filename.
                  Work_Directory := Get_Library_Directory (Lib);

                  --  Always overwrite --work and --workdir.
                  Lib_Args (1) := new String'
                    ("--work=" & Image (Get_Identifier (Lib)));
                  if Work_Directory = Libraries.Local_Directory then
                     Lib_Args (2) := new String'("--workdir=.");
                  else
                     Lib_Args (2) := new String'
                       ("--workdir=" & Image (Work_Directory));
                  end if;
                  Do_Compile (Cmd, Lib_Args, Image (File_Id), True);

                  Work_Directory := Prev_Workdir;

                  Free (Lib_Args (1));
                  Free (Lib_Args (2));
               end;
            end if;

            Has_Compiled := True;
            --  Set the analysis time stamp since the file has just been
            --  analyzed.
            Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp);
         end if;
         Next (Files_It);
      end loop;

      Need_Elaboration := False;
      --  Elaboration.
      --  if libgrt is more recent than the executable (FIXME).
      if Has_Compiled then
         if Flag_Verbose then
            Put_Line ("link due to a file compilation");
         end if;
         Need_Elaboration := True;
      else
         Stamp := File_Time_Stamp (Cmd.Output_File.all);

         if Stamp = Invalid_Time then
            if Flag_Verbose then
               Put_Line ("link due to no binary file");
            end if;
            Need_Elaboration := True;
         else
            if Last_Stamp > Stamp then
               --  if a file is more recent than the executable.
               if Flag_Verbose then
                  Put ("link due to outdated binary file: ");
                  Put (Image (Get_Design_File_Filename (Last_Stamp_File)));
                  New_Line;
               end if;
               Need_Elaboration := True;
            end if;
         end if;
      end if;
      if Need_Elaboration then
         if not Flag_Verbose then
            Put ("elaborate ");
            Put (Image (Primary_Id));
            --Disp_Library_Unit (Get_Library_Unit (Unit));
            New_Line;
         end if;
         Bind (Cmd);
         if not Cmd.Flag_Bind_Only then
            Link (Cmd, Add_Std => True, Disp_Only => False);
            Delete_File (Filelist_Name.all, Success);
         end if;
      end if;
   exception
      when Errorout.Compilation_Error =>
         if Cmd.Flag_Expect_Failure then
            return;
         else
            raise;
         end if;
   end Perform_Action;

   -- helper for --gen-makefile and --gen-depends
   procedure Gen_Makefile (Cmd : in out Command_Comp'Class;
                           Args : Argument_List;
                           Only_Depends : Boolean);

   --  Command Gen_Makefile.
   type Command_Gen_Makefile is new Command_Comp 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"
        or else 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]"
        & ASCII.LF & "  Generate a Makefile for design UNIT"
        & ASCII.LF & "  alias: --gen-makefile";
   end Get_Short_Help;

   function Is_Makeable_File (File : Iir_Design_File) return Boolean is
   begin
      if File = Vhdl.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
   begin
      Gen_Makefile (Cmd, Args, False);
   end Perform_Action;

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

   function Decode_Command (Cmd : Command_Gen_Depends; Name : String)
                           return Boolean
   is
      pragma Unreferenced (Cmd);
   begin
      return Name = "gen-depends"
        or else Name = "--gen-depends";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Gen_Depends) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "gen-depends [OPTS] UNIT [ARCH]"
        & ASCII.LF & "  Generate dependencies of design UNIT"
        & ASCII.LF & "  alias: --gen-depends";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_Gen_Depends;
                             Args : Argument_List) is
   begin
      Gen_Makefile (Cmd, Args, True);
   end Perform_Action;

   -- generate a makefile on stdout
   -- for --gen-depends (Only_Depends) rules and phony targets are omittted
   procedure Gen_Makefile (Cmd : in out Command_Comp'Class;
                           Args : Argument_List;
                           Only_Depends : Boolean)
   is
      HT : constant Character := ASCII.HT;
      Files_List : Iir_List;
      Files_It : List_Iterator;
      File : Iir_Design_File;

      Lib : Iir_Library_Declaration;
      Dir_Id : Name_Id;

      Dep_List : Iir_List;
      Dep_It : List_Iterator;
      Dep_File : Iir;
   begin
      if Only_Depends then
         Set_Elab_Units (Cmd, "--gen-depends", Args);
      else
         Set_Elab_Units (Cmd, "--gen-makefile", Args);
      end if;

      if not Setup_Libraries (True) then
         raise Option_Error;
      end if;
      Files_List := Build_Dependence (Library_Id, Primary_Id, Secondary_Id);

      Ghdllocal.Gen_Makefile_Disp_Header;

      New_Line;

      -- Omit variables.
      if not Only_Depends then
         Ghdllocal.Gen_Makefile_Disp_Variables;

         New_Line;

         Put_Line ("# Default target");
         Put ("all: ");
         Put_Line (Base_Name.all);
         New_Line;
      end if;

      Put_Line ("# Elaboration target");
      Put (Base_Name.all);
      Put (":");
      Files_It := List_Iterate (Files_List);
      while Is_Valid (Files_It) loop
         File := Get_Element (Files_It);
         if Is_Makeable_File (File) then
            Put (" ");
            Put (Get_Object_Filename (File));
         end if;
         Next (Files_It);
      end loop;
      New_Line;
      -- Omit rule.
      if not Only_Depends then
         Put_Line (HT & "$(GHDL) -e $(GHDLFLAGS) $@");
      end if;
      New_Line;

      -- Omit phony target.
      if not Only_Depends then
         Put_Line ("# Run target");
         Put_Line ("run: " & Base_Name.all);
         Put_Line (HT & "$(GHDL) -r " & Base_Name.all & " $(GHDLRUNFLAGS)");
         New_Line;
      end if;

      Put_Line ("# Targets to analyze files");
      Files_It := List_Iterate (Files_List);
      while Is_Valid (Files_It) loop
         File := Get_Element (Files_It);
         Dir_Id := Get_Design_File_Directory (File);
         if not Is_Makeable_File (File) then
            --  Builtin file.
            null;
         else
            Put (Get_Object_Filename (File));
            Put (": ");
            if Dir_Id /= Files_Map.Get_Home_Directory then
               Put (Image (Dir_Id));
               Put (Image (Get_Design_File_Filename (File)));
               New_Line;

               -- Omit dummy rule.
               if not Only_Depends then
                  Put_Line
                    (HT & "@echo ""This file was not locally built ($<)""");
                  Put_Line (HT & "exit 1");
               end if;
            else
               Put (Image (Get_Design_File_Filename (File)));
               New_Line;

               -- Omit rule.
               if not Only_Depends then
                  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_Line (" $<");
               end if;
            end if;
         end if;
         Next (Files_It);
      end loop;
      New_Line;

      Put_Line ("# Files dependences");
      Files_It := List_Iterate (Files_List);
      while Is_Valid (Files_It) loop
         File := Get_Element (Files_It);
         if Is_Makeable_File (File) then
            Put (Get_Object_Filename (File));
            Put (": ");
            Dep_List := Get_File_Dependence_List (File);
            Dep_It := List_Iterate_Safe (Dep_List);
            while Is_Valid (Dep_It) loop
               Dep_File := Get_Element (Dep_It);
               if Dep_File /= File and then Is_Makeable_File (Dep_File)
               then
                  Put (" ");
                  Put (Get_Object_Filename (Dep_File));
               end if;
               Next (Dep_It);
            end loop;
            New_Line;
         end if;
         Next (Files_It);
      end loop;
   end Gen_Makefile;

   procedure Register_Commands is
   begin
      Register_Command (new Command_Analyze);
      Register_Command (new Command_Elab);
      Register_Command (new Command_Run);
      Register_Command (new Command_Elab_Run);
      Register_Command (new Command_Bind);
      Register_Command (new Command_Link);
      Register_Command (new Command_List_Link);
      Register_Command (new Command_Anaelab);
      Register_Command (new Command_Make);
      Register_Command (new Command_Gen_Makefile);
      Register_Command (new Command_Gen_Depends);
      Register_Command (new Command_Dispconfig);
      Register_Command (new Command_Bootstrap);
   end Register_Commands;
end Ghdldrv;