--  GHDL driver - commands invoking gcc.--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold----  GHDL is free software; you can redistribute it and/or modify it under--  the terms of the GNU General Public License as published by the Free--  Software Foundation; either version 2, or (at your option) any later--  version.----  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY--  WARRANTY; without even the implied warranty of MERCHANTABILITY or--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License--  for more details.----  You should have received a copy of the GNU General Public License--  along with GCC; see the file COPYING.  If not, write to the Free--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA--  02111-1307, USA.with Ada.Command_Line; use Ada.Command_Line;with Ada.Text_IO; use Ada.Text_IO;with Ada.Characters.Latin_1;with GNAT.OS_Lib; use GNAT.OS_Lib;with GNAT.Table;with GNAT.Dynamic_Tables;with Libraries;with Name_Table; use Name_Table;with Std_Package;with Types; use Types;with Iirs; use Iirs;with Files_Map;with Flags;with Configuration;--with Disp_Tree;with Default_Pathes;with Interfaces.C_Streams;with System;with Ghdlmain; use Ghdlmain;with Ghdllocal; use Ghdllocal;with Version;package body Ghdldrv is   --  Name of the tools used.   Compiler_Cmd : String_Access := null;   Post_Processor_Cmd : String_Access := null;   Assembler_Cmd : constant String := "as";   Linker_Cmd : constant String := "gcc";   --  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;   --  "-o" string.   Dash_O : String_Access;   --  "-S" string.   Dash_S : String_Access;   --  "-quiet" option.   Dash_Quiet : String_Access;   type Compile_Kind_Type is (Compile_Mcode, Compile_Gcc, Compile_Debug);   Compile_Kind : Compile_Kind_Type := Compile_Gcc;   --  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;   --  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 GNAT.Dynamic_Tables     (Table_Component_Type => String_Access,      Table_Index_Type => Integer,      Table_Low_Bound => 1,      Table_Initial => 4,      Table_Increment => 100);   use Argument_Table_Pkg;   --  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;   --  Display the program spawned in Flag_Disp_Commands is TRUE.   --  Raise COMPILE_ERROR in case of failure.   procedure My_Spawn (Program_Name : String; Args : Argument_List)   is      Status : Integer;   begin      if Flag_Disp_Commands then         Put (Program_Name);         for I in Args'Range loop            Put (' ');            Put (Args (I).all);         end loop;         New_Line;      end if;      Status := Spawn (Program_Name, Args);      if Status = 0 then         return;      elsif Status = 1 then         Error ("compilation error");         raise Compile_Error;      else         Error ("exec error");         raise Exec_Error;      end if;   end My_Spawn;   --  Compile FILE with additional argument OPTS.   procedure Do_Compile (Options : Argument_List; File : String)   is      Obj_File : String_Access;      Asm_File : String_Access;      Post_File : String_Access;      Success : Boolean;   begin      --  Create post file.      case Compile_Kind is         when Compile_Debug =>            Post_File := Append_Suffix (File, Post_Suffix);         when others =>            null;      end case;      --  Create asm file.      case Compile_Kind is         when Compile_Gcc           | Compile_Debug =>            Asm_File := Append_Suffix (File, Asm_Suffix);         when Compile_Mcode =>            null;      end case;      --  Create obj file.      if Compile_Kind = Compile_Mcode or else not Flag_Asm      then         Obj_File := Append_Suffix (File, Get_Object_Suffix.all);      end if;      --  Compile.      declare         P : Natural;         Nbr_Args : Natural := Last (Compiler_Args) + Options'Length + 4;         Args : Argument_List (1 .. Nbr_Args);      begin         P := 0;         for I in First .. Last (Compiler_Args) loop            P := P + 1;            Args (P) := Compiler_Args.Table (I);         end loop;         for I in Options'Range loop            P := P + 1;            Args (P) := Options (I);         end loop;         --  Add -quiet.         if not Flag_Not_Quiet then            P := P + 1;            Args (P) := Dash_Quiet;         end if;         Args (P + 1) := Dash_O;         case Compile_Kind is            when Compile_Debug =>               Args (P + 2) := Post_File;            when Compile_Gcc =>               Args (P + 2) := Asm_File;            when Compile_Mcode =>               Args (P + 2) := Obj_File;         end case;         Args (P + 3) := new String'(File);         My_Spawn (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 Compile_Kind = Compile_Debug then         declare            P : Natural;            Nbr_Args : Natural := Last (Postproc_Args) + 4;            Args : Argument_List (1 .. Nbr_Args);         begin            P := 0;            for I in First .. Last (Postproc_Args) loop               P := P + 1;               Args (P) := Postproc_Args.Table (I);            end loop;            if not Flag_Not_Quiet then               P := P + 1;               Args (P) := Dash_Quiet;            end if;            Args (P + 1) := Dash_O;            Args (P + 2) := Asm_File;            Args (P + 3) := Post_File;            My_Spawn (Post_Processor_Path.all, Args (1 .. P + 3));         end;         Free (Post_File);      end if;      --  Assemble.      if Compile_Kind >= Compile_Gcc then         if Flag_Expect_Failure then            Delete_File (Asm_File.all, Success);         elsif not Flag_Asm then            declare               P : Natural;               Nbr_Args : Natural := Last (Assembler_Args) + 4;               Args : Argument_List (1 .. Nbr_Args);               Success : Boolean;            begin               P := 0;               for I in First .. Last (Assembler_Args) loop                  P := P + 1;                  Args (P) := Assembler_Args.Table (I);               end loop;               Args (P + 1) := Dash_O;               Args (P + 2) := Obj_File;               Args (P + 3) := Asm_File;               My_Spawn (Assembler_Path.all, Args (1 .. P + 3));               Delete_File (Asm_File.all, Success);            end;         end if;      end if;      Free (Asm_File);      Free (Obj_File);   end Do_Compile;   package Filelist is new GNAT.Table     (Table_Component_Type => String_Access,      Table_Index_Type => Natural,      Table_Low_Bound => 1,      Table_Initial => 16,      Table_Increment => 100);   --  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 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;      use Ada.Characters.Latin_1;      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);         return;      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) = LF or Line (L) = CR) loop               L := L - 1;            end loop;            if Line (1) = '>' then               Dir_Len := L - 1;               Dir (1 .. Dir_Len) := Line (2 .. L);            else               if Line (1) = '@' then                  File := new String'(Prefix_Path.all & Line (2 .. L));               else                  if To_Obj then                     File := new String'(Dir (1 .. Dir_Len)                                         & Get_Base_Name (Line (1 .. L))                                         & Get_Object_Suffix.all);                  else                     File := new String'(Line (1 .. L));                  end if;               end if;               Filelist.Increment_Last;               Filelist.Table (Filelist.Last) := 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;   Last_Stamp : Time_Stamp_Id;   Last_Stamp_File : Iir;   function Is_File_Outdated (Design_File : Iir_Design_File) return Boolean   is      use Files_Map;      Dir : Name_Id;      Name : Name_Id;      File : Source_File_Entry;   begin      --  Std.Standard is never outdated.      if Design_File = Std_Package.Std_Standard_File then         return False;      end if;      Dir := Get_Library_Directory (Get_Library (Design_File));      Name := Get_Design_File_Filename (Design_File);      declare         Obj_Pathname : String := Get_Object_Filename (Design_File) & Nul;         Stamp : Time_Stamp_Id;      begin         Stamp := Get_File_Time_Stamp (Obj_Pathname'Address);         --  If the object file does not exist, recompile the file.         if Stamp = Null_Time_Stamp 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 = Null_Time_Stamp           or else Is_Gt (Stamp, Last_Stamp)         then            Last_Stamp := Stamp;            Last_Stamp_File := Design_File;         end if;      end;      --  2) file has been modified.      File := Load_Source_File (Get_Design_File_Directory (Design_File),                                Get_Design_File_Filename (Design_File));      if not Is_Eq (Get_File_Time_Stamp (File),                    Get_File_Time_Stamp (Design_File))      then         if Flag_Verbose then            Put_Line ("file " & Image (Get_File_Name (File))                 & " has been modified");         end if;         return True;      end if;      return False;   end Is_File_Outdated;   function Is_Unit_Outdated (Unit : Iir_Design_Unit) return Boolean   is      Design_File : Iir_Design_File;   begin      --  Std.Standard is never outdated.      if Unit = Std_Package.Std_Standard_Unit then         return False;      end if;      Design_File := Get_Design_File (Unit);      --  1) not yet analyzed:      if Get_Date (Unit) not in Date_Valid then         if Flag_Verbose then            Disp_Library_Unit (Get_Library_Unit (Unit));            Put_Line (" was not analyzed");         end if;         return True;      end if;      --  3) the object file does not exist.      --  Already checked.      --  4) one of the dependence is newer      declare         Depends : Iir_List;