------------------------------------------------------------------------------
--                                                                          --
--                     ASIS UTILITY LIBRARY COMPONENTS                      --
--                                                                          --
--                  A S I S _ U L . E N V I R O N M E N T                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                    Copyright (C) 2004-2010, AdaCore                      --
--                                                                          --
-- Asis Utility Library (ASIS UL) is free software; you can redistribute it --
-- and/or  modify  it  under  terms  of  the  GNU General Public License as --
-- published by the Free Software Foundation; either version 2, or (at your --
-- option)  any later version.  ASIS UL  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  distributed with GNAT; see file --
-- COPYING. If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
-- ASIS UL is maintained by AdaCore (http://www.adacore.com).               --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2005;  --  To make the unit compilable with Ada 95 compiler

with Ada.Characters.Conversions;  use Ada.Characters.Conversions;
with Ada.Text_IO;                 use Ada.Text_IO;

with GNAT.Directory_Operations;   use GNAT.Directory_Operations;

with Hostparm;

with Asis.Ada_Environments;       use Asis.Ada_Environments;
with Asis.Extensions;             use Asis.Extensions;
with Asis.Implementation;         use Asis.Implementation;

with ASIS_UL.Common;              use ASIS_UL.Common;
with ASIS_UL.Compiler_Options;    use ASIS_UL.Compiler_Options;
with ASIS_UL.Debug;               use ASIS_UL.Debug;
with ASIS_UL.Options;
with ASIS_UL.Output;              use ASIS_UL.Output;
with ASIS_UL.Source_Table;        use ASIS_UL.Source_Table;
with ASIS_UL.Utilities;           use ASIS_UL.Utilities;

package body ASIS_UL.Environment is

   -----------------------
   -- Local subprograms --
   -----------------------

   procedure Scan_Parameters;
   --  Scans the tool parameters and initializes the corresponding data
   --  structures.
   --
   --  Because the parameters are tool-specific, the corresponding subunit
   --  should be provided for each tool

   procedure Check_Parameters;
   --  Checks that the tool settings are compatible with each other. All
   --  possible check are tool-specific, the corresponding subunit
   --  should be provided for each tool

   --  These two procedures Scan_Parameters and Check_Parameters - are a part
   --  of the Initialize procedure.  The important thing is that after
   --  finishing Initialize either the source table should contain at least one
   --  name of an existing file (in case if the tool is based on ??? driver),
   --  or ASIS_UL.Common.Arg_File should point to an existing file (in case if
   --  the tool is based on ASIS_UL.One_Arg_Driver driver procedure). File
   --  names in both cases should be full normalized names.
   --
   --  ASIS_UL.Common.Arg_List should collect all the needed options to call
   --  gcc for tree creation

   procedure Tool_Specific_Initialization_1;
   procedure Tool_Specific_Initialization_2;
   --  Do the initialization actions that are specific for a tool. The first
   --  subprogram is called before reading the tool command-line parameters,
   --  the second - when the command-line paramenets have just been read in and
   --  analyzed. If the tool needs any specific initialization actions, the
   --  corresponding subunits should be provided for these subprograms.

   procedure Set_Tree_Name;
   --  This procedure is supposed to be called when a tree file has just been
   --  created for the Ada source which (full normalized) name is contained
   --  in ASIS_UL.Common.Arg_File. It sets into ASIS_UL.Common.Tree_File the
   --  (short) name of the corresponding tree file.

   ----------------------
   -- Check_Parameters --
   ----------------------

   procedure Check_Parameters is separate;

   --------------
   -- Clean_Up --
   --------------

   procedure Clean_Up is
      Success : Boolean := False;
   begin
      Source_Table_Debug_Image;

      Context_Clean_Up;

      --  Cleaning up temporary dir

      if not Debug_Flag_N and then Temp_Dir /= null then

         if not Is_Directory (Temp_Dir.all) then
            --  We may be inside this temporary directory
            Change_Dir ("..");
         end if;

         for J in 1 .. 10 loop
            --  On windows, there might be a slight delay between the return of
            --  the close function on a file descriptor and the actual closing
            --  done by the system. Since it's not possible to remove a
            --  directory as long as there are handles on it, this Remove_Dir
            --  may fail. So, if a call to Remove_Dir raises Directory_Error,
            --  we try several times after some delay, and only if all the
            --  attempts fail, we generate an error message and raise an
            --  exception
            --  be performed.

            begin
               Remove_Dir (Temp_Dir.all, Recursive => True);
               Success := True;
               exit;
            exception
               when Directory_Error =>
                  delay 0.05;
            end;

         end loop;

         if not Success then
            --  Because of some unknown reason the temporary directory cannot
            --  be removed:
            Free (Temp_Dir);  -- to avoid cycling
            Error ("cannot remove temporary directory");
            raise Fatal_Error;
         end if;

         Free (Temp_Dir);

      end if;

   end Clean_Up;

   ----------------------
   -- Context_Clean_Up --
   ----------------------

   procedure Context_Clean_Up is
   begin

      if Is_Open (The_Context) then
         Close (The_Context);
      end if;

      if Has_Associations (The_Context) then
         Dissociate (The_Context);
      end if;

   end Context_Clean_Up;

   --------------------
   -- Go_To_Temp_Dir --
   --------------------

   procedure Go_To_Temp_Dir (With_Dir_For_Comp_Output : Boolean := False) is
      FD        : File_Descriptor;
      Temp_Name : Temp_File_Name;
      Success   : Boolean;
   begin
      --  ??? We create the temp dir by first creating the temp file, then
      --  closing and deleting it, then creating a dir with the same name.
      --  This is not atomary as another program can sneak in between file
      --  deletion and dir creation and snatch this name for itself. This is
      --  quite unlikely and anyway we don't have any other system-independent
      --  way at the moment
      Create_Temp_File (FD, Temp_Name);
      Close (FD);
      Delete_File (Temp_Name, Success);

      if not Success then
         Error ("can not delete the temporary file that was "
              & "just created");

         raise Fatal_Error;
      end if;

      Make_Dir (Temp_Name);

      Temp_Dir :=
        new String'(Temp_Name (Temp_Name'First .. Temp_Name'Last - 1));

      if Is_Regular_File ("gnat.adc") then

         if Hostparm.OpenVMS then
            Copy_File
              (Name     => "gnat.adc",
               Pathname => Temp_Dir.all & Directory_Separator & "gnat.adc",
               Success  => Success,
               Mode     => Copy,
               Preserve => None);

         else
            Copy_File
              (Name     => "gnat.adc",
               Pathname => Temp_Dir.all & Directory_Separator & "gnat.adc",
               Success  => Success,
               Mode     => Copy);
         end if;

      end if;

      Change_Dir (Temp_Dir.all);

      if Project_File /= null
        and then
         Project_Support_Type = Use_Tmp_Project_File
      then

         declare
            Temp_Project_File : File_Type;
         begin
            --  Creating the temporary project file
            Create (Temp_Project_File, Out_File, "tmp.gpr");

            Put (Temp_Project_File, "project Tmp extends """);
            Put (Temp_Project_File, Project_File.all);
            Put (Temp_Project_File, """ is");
            New_Line (Temp_Project_File);

            Put (Temp_Project_File, "   for Object_Dir use ""."";");
            New_Line (Temp_Project_File);

            Put (Temp_Project_File, "end Tmp;");
            New_Line (Temp_Project_File);

            Close (Temp_Project_File);

            --  Storing the temporary project file as an option:

            Store_Option ("-Ptmp.gpr");
            Set_Arg_List;

         exception
            when others =>
               Error ("can not create the temporary project file");
               raise Fatal_Error;
         end;

      end if;

      if With_Dir_For_Comp_Output then
         Create_Temp_File (FD, Temp_Name);
         Close (FD);
         Delete_File (Temp_Name, Success);

         if not Success then
            Error ("can not delete the temporary file that was "
                 & "just created");

            raise Fatal_Error;
         end if;

         Make_Dir (Temp_Name);

         Compiler_Output_File_Name := new String'
           (Temp_Name (Temp_Name'First .. Temp_Name'Last - 1) &
            Directory_Separator & "compiler_diag.txt");
      end if;

   exception
      when Directory_Error =>
         Error ("can not create the temporary directory");
         raise Fatal_Error;
   end Go_To_Temp_Dir;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      Tool_Specific_Initialization_1;
      --  A tool-specific version should be provided!

      Scan_Parameters;  --  A tool-specific version should be provided!
      Check_Parameters; --  A tool-specific version should be provided!

      Tool_Specific_Initialization_2;
      --  A tool-specific version should be provided!

      if not ASIS_UL.Options.Nothing_To_Do then
         Go_To_Temp_Dir;
      end if;

   exception
      when Parameter_Error | Fatal_Error =>
         --  The diagnosis is already generated
         raise Fatal_Error;
      when others =>
         Error ("initialization failed");
         --  Exception info will be generated in main driver
         raise;
   end Initialize;

   ---------------------
   -- Prepare_Context --
   ---------------------

   procedure Prepare_Context (Success : out Boolean) is
   begin
      Compile
        (Source_File  => ASIS_UL.Common.Arg_File,
         Args         => ASIS_UL.Compiler_Options.Arg_List.all,
         Success      => Success,
         GCC          => Gcc_To_Call,
         Use_GNATMAKE => Use_Gnatmake_To_Compile,
         Use_Temp_Prj => Project_Support_Type = Use_Tmp_Project_File,
         Display_Call => Debug_Flag_D);

      if not Success then
         Error ("the argument source is illegal");
      else
         Set_Tree_Name;

         Asis.Implementation.Initialize ("-ws");

         Asis.Ada_Environments.Associate
           (The_Context => The_Context,
            Name        => "",
            Parameters  => "-C1 " & To_Wide_String (Tree_File.all));

         Open (The_Context);

         if Debug_Flag_T then
            Print_Tree_Sources;
         end if;

         The_CU := Asis.Extensions.Main_Unit_In_Current_Tree (The_Context);
      end if;

   end Prepare_Context;

   ---------------------
   -- Scan_Parameters --
   ---------------------

   procedure Scan_Parameters is separate;

   -------------------
   -- Set_Tree_Name --
   -------------------

   procedure Set_Tree_Name is
      Dot_Idx : Natural := 0;
      DS_Idx  : Natural;
   begin

      Free (Tree_File);

      if Arg_File = null then
         Tree_File := new String'("");
      else
         for J in reverse Arg_File'Range loop
            if Arg_File (J) = '.' then
               Dot_Idx := J - 1;
               exit;
            end if;
         end loop;

         DS_Idx := Arg_File'First;

         for J in reverse Arg_File'Range loop
            if Arg_File (J) = Directory_Separator then
               DS_Idx := J + 1;
               exit;
            end if;
         end loop;

         Tree_File := new String'(Arg_File (DS_Idx .. Dot_Idx) & ".adt");

      end if;

   end Set_Tree_Name;

   ----------------------------------
   -- Tool_Specific_Initialization --
   ----------------------------------

   procedure Tool_Specific_Initialization_1 is separate;
   procedure Tool_Specific_Initialization_2 is separate;

end ASIS_UL.Environment;
