------------------------------------------------------------------------------
--                                                                          --
--                           GNATTEST COMPONENTS                            --
--                                                                          --
--                 G N A T T E S T . E N V I R O N M E N T                  --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                       Copyright (C) 2011, AdaCore                        --
--                                                                          --
-- GNATTEST  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.  GNATTEST  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.,                                      --
--                                                                          --
-- GNATTEST is maintained by AdaCore (http://www.adacore.com).              --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Text_IO;                use Ada.Text_IO;
--  with Ada.Strings;                use Ada.Strings;
--  with Ada.Strings.Fixed;          use Ada.Strings.Fixed;

--  with Ada.Containers.Indefinite_Doubly_Linked_Lists;

with Asis.Ada_Environments;      use Asis.Ada_Environments;

with GNAT.Command_Line;          use GNAT.Command_Line;
with GNAT.Directory_Operations;  use GNAT.Directory_Operations;

with ASIS_UL.Common;
with ASIS_UL.Compiler_Options;   use ASIS_UL.Compiler_Options;
with ASIS_UL.Debug;              use ASIS_UL.Debug;
with ASIS_UL.Output;             use ASIS_UL.Output;

with GNATtest.Options;              use GNATtest.Options;
with GNATtest.Common;               use GNATtest.Common;
with GNATtest.Stub.Source_Table;    use GNATtest.Stub.Source_Table;
with GNATtest.Harness.Source_Table; use GNATtest.Harness.Source_Table;

with GNAT.Strings;
with GNATCOLL.Projects;          use GNATCOLL.Projects;
with GNATCOLL.VFS;               use GNATCOLL.VFS;

package body GNATtest.Environment is

   Parameter_Error : exception;
   --  Is raised if the initialization is impossible or fails down because of
   --  any reason

   Output_M : Output_Mode := Default_Output_Mode;
   Output_M_Set : Boolean := False;

   Default_Stubs_Set : Boolean := False;

   Run_Dir : String_Access;
   --  Directory from which the tool was called.

      --  Project support
   Source_Project_Tree : GNATCOLL.Projects.Project_Tree;
   --  Source project file name. Used for extraction of source files and
   --  paths for compiler.

   Env   : Project_Environment_Access;

   Recursive_Sources : Boolean := False;

   Config_Name : constant String := "gnat.adc";

   Gnatls_To_Call : String_Access;

   --  Temporary source file name storage. After determining in which mode
   --  the tool works sources are to be transfered to corresponding source
   --  table.

   use List_Of_Strings;

   Source_Buffer  : List_Of_Strings.List;
   Ext_Var_Buffer : List_Of_Strings.List;
   SB_Cur         : List_Of_Strings.Cursor;

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

   procedure Scan_Parameters;
   --  Scans the command-line parameters and sets the metrics to compute and
   --  sources to process.

   procedure Check_Parameters;
   --  Checks that parameter settings are compatible. Raises Parameter_Error
   --  and generates the diagnostic message if the check fails.

   procedure Create_Temp_Dir;
   --  Creates the temporary directory and stores its name in Temp_Dir.

   procedure Brief_Help;
   --  Prints out the brief help.

   procedure Scan_Dir_Affix (Affix : String);
   --  Sets the values of Test_Dir_Prefix and Test_Dir_Suffix options.

   procedure Check_Subdir;
   --  Checks if there are no intersections between target and source dirs. If
   --  so, tries to create all target subdirs.

   procedure Check_Parallel;
   --  Checks if there are no intersections between target and source dirs. If
   --  so, tries to create all target parallel dirs.

   procedure Check_Separate_Root;
   --  Checks if there are no intersections between target and source dirs. If
   --  so, tries to create a directori hierarchy similar to one of the tested
   --  sources.

   function Is_Externally_Built (File : Virtual_File) return Boolean;
   --  Checks if the given source file belongs to an externally build library.

   procedure Create_Dirs (Target_Dirs : File_Array_Access);
   --  Creates given directories.

   function Non_Null_Intersection
     (Left  : File_Array_Access;
      Right : File_Array_Access)
      return Boolean;
   --  Returns True if two file arrays have at least one common file.

   function All_Source_Locations return File_Array_Access;
   --  Returns an array of all directories that may have source files.
   --  In case of project option, returns the list of recursively collected
   --  source dirs, otherwise collects the list from argument source files.

   procedure Get_Naming_Info
     (Source_Project_Tree : GNATCOLL.Projects.Project_Tree);
   --  Gathers all naming info and creates a file with corresponding pragmas.

   procedure Update_Path_With_Project (Dirs : GNATCOLL.VFS.File_Array);
   --  Treats all the source dirs from project as -I option parameters.
   --  Also sets the value of Source_Dirs_Conflict flag.

   procedure Add_Test_Paths;

   procedure Register_Gnattest_Specific_Attributes;

   procedure Get_Gnattest_Specific_Attributes
     (Source_Project_Tree : GNATCOLL.Projects.Project_Tree);

   --------------------
   -- Add_Test_Paths --
   --------------------

   procedure Add_Test_Paths is
      Tmp : String_Access;
   begin
      GNATtest.Stub.Source_Table.Reset_Source_Iterator;
      loop
         Tmp := new String'(GNATtest.Stub.Source_Table.Next_Source_Name);
         if Tmp.all = "" then
            Free (Tmp);
            exit;
         end if;

         Store_I_Option (Get_Source_Output_Dir (Tmp.all));
         Free (Tmp);
      end loop;
   end Add_Test_Paths;

   ------------------------------
   -- Update_Path_With_Project --
   ------------------------------

   procedure Update_Path_With_Project (Dirs : GNATCOLL.VFS.File_Array) is
   begin
      for F in Dirs'Range loop
         Store_I_Option (Dirs (F).Display_Full_Name);
      end loop;
   end Update_Path_With_Project;
   --------------------------
   -- All_Source_Locations --
   --------------------------

   function All_Source_Locations return File_Array_Access is
      Source_Dirs : File_Array_Access := new File_Array'(Empty_File_Array);
      Tmp         : String_Access;
   begin
      if Source_Prj.all /= ("") then
         --  If we're here, than the project has been successfully loaded.

         Append
           (Source_Dirs,
            Source_Project_Tree.Root_Project.Source_Dirs (Recursive => True));
      else

         GNATtest.Stub.Source_Table.Reset_Location_Iterator;

         loop
            Tmp := new String'(Normalize_Pathname
              (Name           =>
                 GNATtest.Stub.Source_Table.Next_Source_Location,
               Case_Sensitive => False));
            exit when Tmp.all = "";

            Append (Source_Dirs, GNATCOLL.VFS.Create (+Tmp.all));
         end loop;

      end if;

      return Source_Dirs;
   end All_Source_Locations;

   ----------------
   -- Brief_Help --
   ----------------

   procedure Brief_Help is
   begin
      Put_Line ("usage: gnattest -Pprjname [--harness-dir=dir] [options] " &
                "{filename} [-cargs switches]");

      Put_Line ("");
      Put_Line (" -Pprjname                  - " &
                "specifies the project that allow locating the source files.");
      Put_Line ("                              " &
                "If no [filenames] are provided on the command line, all");
      Put_Line ("                              " &
                "project sources are used as input.");
      Put_Line (" --additional-tests=prjname - " &
                "sources described in projname are considered potential ");
      Put_Line ("                              " &
                "additional manual tests to be added to the test suite.");

      Put_Line ("");
      Put_Line (" --harness-dir=dirname   - output dir for test harness");
      Put_Line ("                           " &
                "(it can also be passed as project attribute)");

      Put_Line ("");
      Put_Line (" --subdir=dirname        - " &
                "test files are put in the dirname subdirectories");
      Put_Line ("                           " &
                "located at the same level as source files");
      Put_Line (" --separate-root=dirname - " &
                "test files are put in a same directory hierarchy");
      Put_Line ("                           " &
                "as the sources with dirname as the root directory");
      Put_Line ("");
      Put_Line (" -q  - quiet mode");
      Put_Line (" -v  - verbose mode");
      Put_Line (" -r  - " &
                "consider recursively all sources from all projects.");
      Put_Line ("");
      Put_Line (" --liskov       - " &
                "Enables Liskov verification: run all tests from all parents" &
                " in order");
      Put_Line ("                  " &
                "to check substitutability.");
      Put_Line (" --harness-only - " &
                "all argument sources are treated as tests to be added " &
                "to the suite");

   end Brief_Help;

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

   procedure Check_Parameters is

      Tmp          : String_Access;
      No_More_Args : Boolean := True;

      --  Project support:
      Files : File_Array_Access;

      Project_Success : Boolean := False;

      procedure Add_AUnit_Paths;
      --  Creates a dummy project file importing aunit, then trying to load it.
      --  If the attempt fails that means that AUnit is not on default project
      --  path.

      procedure Set_Gnattest_Generated_Present
        (Source_Project_Tree : GNATCOLL.Projects.Project_Tree);
      --  Checks if gnattest_generated.ads is already among sources.

      procedure Set_Ext_Values;

      procedure Set_Inherited_Switches
        (Source_Project_Tree : GNATCOLL.Projects.Project_Tree);

      ---------------------
      -- Add_AUnit_Paths --
      ---------------------

      procedure Add_AUnit_Paths is
         Output_File : File_Type;
      begin
         Create
           (Output_File,
            Out_File,
            Temp_Dir.all & Directory_Separator & "default.gpr");
         Put_Line (Output_File, "with ""aunit"";");
         Put_Line (Output_File, "project default is");
         Put_Line (Output_File, "end default;");
         Close (Output_File);

         Source_Project_Tree.Load
           (GNATCOLL.VFS.Create
              (+(Temp_Dir.all & Directory_Separator & "default.gpr")), Env);

         Update_Path_With_Project
           (Source_Project_Tree.Root_Project.Source_Dirs (Recursive => True));

      exception
         when GNATCOLL.Projects.Invalid_Project =>
            Report_Err ("gnattest: aunit not installed");
            raise Parameter_Error;

      end Add_AUnit_Paths;

      procedure Set_Ext_Values is
         Vars : Scenario_Variable_Array :=
           Source_Project_Tree.Scenario_Variables;

         Var_Name, Var_Val : String_Access;

      begin
         SB_Cur := Ext_Var_Buffer.First;
         loop
            exit when SB_Cur = List_Of_Strings.No_Element;

            declare
               S : constant String := List_Of_Strings.Element (SB_Cur);
               F_Idx : constant Integer := S'First;
               L_Idx : constant Integer := S'Last;
            begin
               for I in S'Range loop
                  if S (I) = '=' then
                     Var_Name := new String'(S (F_Idx .. I - 1));
                     Var_Val  := new String'(S (I + 1 .. L_Idx));
                  end if;
               end loop;

               if Var_Name = null then
                  Report_Std ("-X" & S & " is an illegal option");
                  raise Parameter_Error;
               end if;
            end;

            for I in Vars'Range loop
               if External_Name (Vars (I)) = Var_Name.all then

                  declare
                     Pos_Vals : constant GNAT.Strings.String_List :=
                       Source_Project_Tree.Possible_Values_Of (Vars (I));
                     Present : Boolean := False;
                  begin

                     for J in Pos_Vals'Range loop
                        if Pos_Vals (J).all = Var_Val.all then
                           Present  := True;
                           exit;
                        end if;
                     end loop;

                     if not Present then
                        Report_Err
                          ("value " & Var_Val.all &
                           " is illegal for " & Var_Name.all);
                        raise Parameter_Error;
                     end if;

                  end;

                  Set_Value (Vars (I), Var_Val.all);
                  exit;
               end if;
            end loop;

            List_Of_Strings.Next (SB_Cur);
            Free (Var_Name);
            Free (Var_Val);
         end loop;

         Source_Project_Tree.Change_Environment (Vars);
         Source_Project_Tree.Recompute_View;

      end Set_Ext_Values;

      procedure Set_Gnattest_Generated_Present
        (Source_Project_Tree : GNATCOLL.Projects.Project_Tree)
      is
         Files : File_Array_Access;
      begin
         Files :=
           Source_Project_Tree.Root_Project.Source_Files (Recursive => True);

         for F in Files'Range loop
            if not Is_Externally_Built (Files (F)) then

               if Files (F).Display_Base_Name = "gnattest_generated.ads" then
                  Gnattest_Generated_Present := True;
                  exit;
               end if;

            end if;
         end loop;

      end Set_Gnattest_Generated_Present;

      procedure Set_Inherited_Switches
        (Source_Project_Tree : GNATCOLL.Projects.Project_Tree)
      is
         Target_Switches : constant String_List :=
           (new String'("-gnatE"),
            new String'("-gnat12"),
            new String'("-gnat2012"));

         Switches : String_List_Access;

         Proj : constant Project_Type := Source_Project_Tree.Root_Project;
      begin
         if Has_Attribute (Proj, Compiler_Default_Switches_Attribute) then
            Switches :=
              Attribute_Value
              (Proj,
               Compiler_Default_Switches_Attribute,
               "ada");
         end if;

         if Switches = null then
            return;
         end if;

         for I in Switches'Range loop
            for J in Target_Switches'Range loop
               if Switches (I).all = Target_Switches (J).all then
                  Inherited_Switches.Append (Switches (I).all);
               end if;
            end loop;
         end loop;
      end Set_Inherited_Switches;

   begin

      --  Setting up default project path for project parsing.
      Initialize (Env);

      declare
         Gnatls : constant String  := "gnatls";

         Suffix_Pos : Integer;
         First_Idx  : Integer;
         Prefix     : String_Access;
      begin
         if ASIS_UL.Common.Gcc_To_Call = null then
            Prefix := new String'("");

         else
            Suffix_Pos := ASIS_UL.Common.Gcc_To_Call.all'Last;
            First_Idx  := ASIS_UL.Common.Gcc_To_Call.all'First;

            loop
               if ASIS_UL.Common.Gcc_To_Call.all
                 (Suffix_Pos - 2 .. Suffix_Pos) = "gcc"
               then
                  Prefix := new String'
                    (ASIS_UL.Common.Gcc_To_Call.all
                       (First_Idx .. Suffix_Pos - 3));
                  exit;
               end if;

               Suffix_Pos := Suffix_Pos - 1;
            end loop;
         end if;

         Gnatls_To_Call := new String'(Prefix.all & Gnatls);
      end;
      Env.Set_Path_From_Gnatls (Gnatls_To_Call.all, Tmp);
      Free (Tmp);

      Create_Temp_Dir;
      Register_Gnattest_Specific_Attributes;

      if Source_Prj.all /= "" then
         if not Is_Regular_File (Source_Prj.all) then

            if Is_Regular_File (Source_Prj.all & ".gpr") then
               Tmp := new String'(Source_Prj.all & ".gpr");
               Free (Source_Prj);
               Source_Prj := Tmp;
               Tmp := null;
            else
               Report_Err ("gnattest: project file " &
                           Source_Prj.all & " does not exist");
               raise Parameter_Error;
            end if;
         end if;

         Add_AUnit_Paths;

         Tmp := new String'(Normalize_Pathname
           (Name           => Source_Prj.all,
            Case_Sensitive => False));
         Free (Source_Prj);
         Source_Prj := new String'(Tmp.all);
         Free (Tmp);

         Source_Project_Tree.Load (GNATCOLL.VFS.Create (+Source_Prj.all), Env);
         Update_Path_With_Project
           (Source_Project_Tree.Root_Project.Source_Dirs (Recursive => True));
         Set_Gnattest_Generated_Present (Source_Project_Tree);

         Project_Success := True;
         Get_Gnattest_Specific_Attributes (Source_Project_Tree);
         Set_Ext_Values;

         if Output_M = Separate_Root then
            if Separate_Root_Dir.all = Harness_Dir.all then
               Report_Err
                 ("harness dir and separate root dir should not be the same");
               raise Parameter_Error;
            end if;
         end if;

      else
         Report_Err ("gnattest: project file not specified");
         Brief_Help;
         raise Parameter_Error;
      end if;

      SB_Cur := Source_Buffer.First;
      loop

         exit when SB_Cur = List_Of_Strings.No_Element;

         if Harness_Only then
            GNATtest.Harness.Source_Table.Add_Source_To_Process
              (List_Of_Strings.Element (SB_Cur), No_More_Args);
         else
            GNATtest.Stub.Source_Table.Add_Source_To_Process
              (List_Of_Strings.Element (SB_Cur), No_More_Args);
         end if;

         List_Of_Strings.Next (SB_Cur);
      end loop;

      Source_Buffer.Clear;

      if Harness_Dir /= null then

         if Is_Regular_File (Harness_Dir.all) then
            Report_Err ("gnattest: cannot create harness directory");
            raise Parameter_Error;
         elsif not Is_Directory (Harness_Dir.all) then

            begin
               Make_Dir (Harness_Dir.all);
            exception
               when Directory_Error =>
                  Report_Err ("gnattest: cannot create harness directory");
                  raise Parameter_Error;
            end;

         end if;

      else
         Report_Err ("gnattest: harness directory not specified");
         raise Parameter_Error;
      end if;

      Tmp := new String'(Normalize_Pathname
        (Name           => Harness_Dir.all,
         Case_Sensitive => False));
      Free (Harness_Dir);
      Harness_Dir := new String'(Tmp.all & Directory_Separator);
      Free (Tmp);

      Run_Dir := new String'
        (Normalize_Pathname (Name => Get_Current_Dir,
                             Case_Sensitive => False));

      Change_Dir (Temp_Dir.all);
      if Project_Success then
         Get_Naming_Info (Source_Project_Tree);
         Set_Inherited_Switches (Source_Project_Tree);
      end if;

      if Harness_Only then
         if GNATtest.Harness.Source_Table.SF_Table_Empty then

            if Source_Prj.all = "" then

               Report_Err ("No input source file set");
               Brief_Help;
               raise Parameter_Error;

            else

               Files :=
                 Source_Project_Tree.Root_Project.Source_Files
                   (Recursive => False);

               --  If Files is still empty, that means that the given
               --  project does not have any source files.
               if Files'Length = 0 then
                  Report_Err
                    (Source_Prj.all & " doesn't contain source files");
                  Brief_Help;
                  raise Parameter_Error;
               end if;

               for F in Files'Range loop
                  if not Is_Externally_Built (Files (F)) then

                     if
                       Source_Project_Tree.Info (Files (F)).Unit_Part =
                       Unit_Spec
                     then
                        GNATtest.Harness.Source_Table.Add_Source_To_Process
                          (Files (F).Display_Full_Name,
                           No_More_Args);
                        exit when No_More_Args;
                     end if;
                  end if;
               end loop;

               --  If SF_Table is still empty, that means that the given
               --  project does not have any testable source files.
               if GNATtest.Harness.Source_Table.SF_Table_Empty then
                  Report_Err
                    (Source_Prj.all &
                     " doesn't contain testable source files");
                  Brief_Help;
                  raise Parameter_Error;
               end if;

            end if;

         end if;
      else

         if GNATtest.Stub.Source_Table.SF_Table_Empty then
            if Source_Prj.all = "" then
               Report_Err ("No input source file set");
               Brief_Help;
               raise Parameter_Error;

            else
               Files :=
                 Source_Project_Tree.Root_Project.Source_Files
                   (Recursive => Recursive_Sources);

               --  If Files is still empty, that means that the given
               --  project does not have any source files.
               if Files'Length = 0 then
                  Report_Err
                    (Source_Prj.all & " doesn't contain source files");
                  raise Parameter_Error;
               end if;

               for F in Files'Range loop
                  if not Is_Externally_Built (Files (F)) then

                     if
                       Source_Project_Tree.Info (Files (F)).Unit_Part =
                       Unit_Spec
                     then
                        GNATtest.Stub.Source_Table.Add_Source_To_Process
                          (Files (F).Display_Full_Name,
                           No_More_Args);
                        exit when No_More_Args;
                     end if;
                  end if;
               end loop;

               --  If SF_Table is still empty, that means that the given
               --  project does not have any testable source files.
               if GNATtest.Stub.Source_Table.SF_Table_Empty then
                  Report_Err
                    (Source_Prj.all &
                     " doesn't contain testable source files");
                  raise Parameter_Error;
               end if;
            end if;
         end if;

         case Output_M is
            when Subdir =>
               Check_Subdir;
            when Parallel =>
               Check_Parallel;
            when Separate_Root =>
               Check_Separate_Root;
         end case;
      end if;

      Add_Test_Paths;

      if Additional_Tests_Prj /= null then

         Change_Dir (Run_Dir.all);
         Tmp := new String'(Normalize_Pathname
           (Name           => Additional_Tests_Prj.all,
            Case_Sensitive => False));
         Free (Additional_Tests_Prj);
         Additional_Tests_Prj := new String'(Tmp.all);
         Free (Tmp);
         Change_Dir (Temp_Dir.all);

         if not Is_Regular_File (Additional_Tests_Prj.all) then
            if Is_Regular_File (Additional_Tests_Prj.all & ".gpr") then
               Tmp := new String'(Additional_Tests_Prj.all & ".gpr");
               Free (Additional_Tests_Prj);
               Additional_Tests_Prj := Tmp;
               Tmp := null;
            else
               Report_Err ("gnattest: project file " &
                           Additional_Tests_Prj.all & " does not exist");
               raise Parameter_Error;
            end if;
         end if;

         Source_Project_Tree.Load
           (GNATCOLL.VFS.Create (+Additional_Tests_Prj.all), Env);
         Update_Path_With_Project
           (Source_Project_Tree.Root_Project.Source_Dirs (Recursive => True));

         Set_Gnattest_Generated_Present (Source_Project_Tree);

         Files := Source_Project_Tree.Root_Project.Source_Files
           (Recursive => False);

         for F in Files'Range loop
            if not Is_Externally_Built (Files (F)) then

               if
                 Source_Project_Tree.Info (Files (F)).Unit_Part =
                 Unit_Spec
               then
                  GNATtest.Harness.Source_Table.Add_Source_To_Process
                    (Files (F).Display_Full_Name,
                     No_More_Args);
                  exit when No_More_Args;
               end if;
            end if;
         end loop;

      end if;

      if not Harness_Only then
         Store_I_Option (Harness_Dir.all & Directory_Separator & "common");
      end if;

      Process_ADA_PRJ_INCLUDE_FILE;
      Store_I_Options;
      Set_Arg_List;

      Free (Env);
   end Check_Parameters;

   --------------------
   -- Check_Parallel --
   --------------------

   procedure Check_Parallel is
      Tmp             : String_Access;
      Base_Dir_Name   : String_Access;
      Target_Dir_Name : String_Access;

      Idx         : Integer;

      Future_Dirs : File_Array_Access := new File_Array'(Empty_File_Array);
      --  List of dirs to be generated. The list is checked for intersections
      --  with source dirs before any new directories are created.

   begin
      GNATtest.Stub.Source_Table.Reset_Location_Iterator;

      loop
         Tmp := new String'(GNATtest.Stub.Source_Table.Next_Source_Location);
         exit when Tmp.all = "";

         if Tmp.all (Tmp.all'Last) = Directory_Separator then
            Idx := Tmp.all'Last - 1;
         else
            Idx := Tmp.all'Last;
         end if;

         for I in reverse Tmp.all'First .. Idx loop
            if Tmp.all (I) = Directory_Separator then
               Base_Dir_Name := new String'(Tmp.all (Tmp.all'First .. I - 1));
               Target_Dir_Name := new String'(Tmp.all (I + 1 .. Tmp.all'Last));
               exit;
            end if;
         end loop;

         if Base_Dir_Name = null then
            Report_Err ("gnattest: sources in root directory," &
                        " cannot make parallel dirs");
            raise Parameter_Error;
         end if;

         Append (Future_Dirs, GNATCOLL.VFS.Create
           (+(Base_Dir_Name.all   &
              Directory_Separator &
              Test_Dir_Prefix.all &
              Target_Dir_Name.all &
              Test_Dir_Suffix.all)));
      end loop;

      if Non_Null_Intersection (Future_Dirs, All_Source_Locations) then
         Report_Err ("gnattest: invalid output directory, cannot mix up " &
                     "tests and infrastructure");
         raise Parameter_Error;
      end if;

      Create_Dirs (Future_Dirs);
      Set_Parallel_Output;
   end Check_Parallel;

   -------------------------
   -- Check_Separate_Root --
   -------------------------

   procedure Check_Separate_Root is
      Tmp, Buff    : String_Access;
      Maximin_Root : String_Access;
      Root_Length  : Integer;

      Future_Dirs : File_Array_Access := new File_Array'(Empty_File_Array);
      --  List of dirs to be generated. The list is checked for intersections
      --  with source dirs before any new directories are created.

      function Common_Root (Left : String; Right : String) return String;
      --  Returns the coincident beginning of both paths or an empty string.

      -------------------
      --  Common_Root  --
      -------------------

      function Common_Root (Left : String; Right : String) return String is
         Idxl : Integer := Left'First;
         Idxr : Integer := Right'First;

         Last_Dir_Sep_Index : Integer := Idxl - 1;
         --  We need to check for the following:
         --  ...somepath/dir/
         --  ...somepath/directory/

      begin
         if Left = "" or Right = "" then
            return "";
         end if;

         loop
            if Left (Idxl) = Directory_Separator
              and then Right (Idxr) = Directory_Separator
            then
               Last_Dir_Sep_Index := Idxl;
            end if;

            if Left (Idxl) /= Right (Idxr) then
               if Left (Idxl) = Directory_Separator
                 or else Right (Idxr) = Directory_Separator
               then
                  return Left (Left'First .. Last_Dir_Sep_Index);
               end if;

               return Left (Left'First .. Idxl - 1);
            end if;

            exit when Idxl = Left'Last or Idxr = Right'Last;

            Idxl := Idxl + 1;
            Idxr := Idxr + 1;
         end loop;

         return Left (Left'First .. Idxl);
      end Common_Root;

   begin
      GNATtest.Stub.Source_Table.Reset_Location_Iterator;
      Tmp := new String'(GNATtest.Stub.Source_Table.Next_Source_Location);
      Maximin_Root := new String'(Tmp.all);

      loop
         Tmp := new String'(GNATtest.Stub.Source_Table.Next_Source_Location);
         exit when Tmp.all = "";

         Buff := new String'(Common_Root (Tmp.all, Maximin_Root.all));

         if Buff.all = "" then
            Report_Err ("gnattest: sources have different root dirs, " &
                        "cannot apply separate root output");
            raise Parameter_Error;
         end if;

         Free (Maximin_Root);
         Maximin_Root := new String'(Buff.all);
         Free (Buff);
         Free (Tmp);
      end loop;

      Root_Length := Maximin_Root.all'Length;

      Change_Dir (Run_Dir.all);

      Separate_Root_Dir := new String'
        (Normalize_Pathname (Name => Separate_Root_Dir.all,
                             Case_Sensitive => False));

      GNATtest.Stub.Source_Table.Reset_Location_Iterator;

      loop
         Tmp := new String'(GNATtest.Stub.Source_Table.Next_Source_Location);
         exit when Tmp.all = "";

         Append (Future_Dirs, GNATCOLL.VFS.Create
                 (+(Separate_Root_Dir.all & Directory_Separator &
                    Tmp.all (Root_Length + 1 .. Tmp.all'Last))));

         Free (Tmp);
      end loop;

      if Non_Null_Intersection (Future_Dirs, All_Source_Locations) then
         Report_Err ("gnattest: invalid output directory, cannot mix up " &
                     "tests and infrastructure");
         raise Parameter_Error;
      end if;

      Create_Dirs (Future_Dirs);
      Set_Separate_Root (Maximin_Root.all);

      Change_Dir (Temp_Dir.all);
   end Check_Separate_Root;

   ------------------
   -- Check_Subdir --
   ------------------

   procedure Check_Subdir is
      Tmp : String_Access;

      Future_Dirs : File_Array_Access := new File_Array'(Empty_File_Array);
      --  List of dirs to be generated. The list is checked for intersections
      --  with source dirs before any new directories are created.
   begin
      GNATtest.Stub.Source_Table.Reset_Location_Iterator;

      loop
         Tmp := new String'(GNATtest.Stub.Source_Table.Next_Source_Location);
         exit when Tmp.all = "";

         Append (Future_Dirs, GNATCOLL.VFS.Create
                 (+(Tmp.all & Directory_Separator & Test_Subdir_Name.all)));
      end loop;

      if Non_Null_Intersection (Future_Dirs, All_Source_Locations) then
         Report_Err ("gnattest: invalid output directory, cannot mix up " &
                     "tests and infrastructure");
         raise Parameter_Error;
      end if;

      Create_Dirs (Future_Dirs);
      Set_Subdir_Output;
   end Check_Subdir;

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

   procedure Clean_Up is
   begin
      Context_Clean_Up;

      --  Cleaning up temporary dir

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

         begin
            Remove_Dir (Temp_Dir.all, Recursive => True);
         exception
            when Directory_Error =>
               Free (Temp_Dir);  -- to avoid cycling
               Report_Err ("gnattest: cannot remove temporary directory");
               raise Fatal_Error;
         end;

         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;

   -----------------
   -- Create_Dirs --
   -----------------

   procedure Create_Dirs (Target_Dirs : File_Array_Access) is
      First : Integer;
   begin
      for J in Target_Dirs'Range loop
         declare
            Target_Dir : constant String :=
                           Target_Dirs.all (J).Display_Full_Name;
         begin
            First := Target_Dir'First;

            if Is_Regular_File (Target_Dir) then
               Report_Err ("gnattest: cannot create dir " & Target_Dir);
               raise Parameter_Error;
            end if;

            for Idx in Target_Dir'Range loop
               if Target_Dir (Idx) = Directory_Separator
                 or else Idx = Target_Dir'Last
               then
                  if not Is_Directory (Target_Dir (First .. Idx)) then
                     begin
                        Make_Dir (Target_Dir (First .. Idx));
                     exception
                        when Directory_Error =>
                           Report_Err ("gnattest: cannot create dir " &
                                       Target_Dir (First .. Idx));
                           raise Parameter_Error;
                     end;
                  end if;
               end if;
            end loop;
         end;
      end loop;
   end Create_Dirs;

   ---------------------
   -- Create_Temp_Dir --
   ---------------------

   procedure Create_Temp_Dir is
      FD        : File_Descriptor;
      Temp_Name : Temp_File_Name;
      Success   : Boolean;

   begin
      --  Here we use exactly the same approach as in gnatelim

      --  ??? 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
         Report_Err ("gnattest: cannot 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));

   exception
      when Directory_Error =>
         Report_Err ("gnattest: cannot create the temporary directory");
         raise Fatal_Error;
   end Create_Temp_Dir;

   --------------------------------------
   -- Get_Gnattest_Specific_Attributes --
   --------------------------------------

   procedure Get_Gnattest_Specific_Attributes
     (Source_Project_Tree : GNATCOLL.Projects.Project_Tree)
   is
      Proj : constant Project_Type := Source_Project_Tree.Root_Project;
      GT_Package : constant String := "gnattest";
   begin

      declare
         Attr : constant Attribute_Pkg_String :=
           Build (GT_Package, "harness_dir");
      begin
         if Attribute_Value (Proj, Attr) /= "" then
            if Harness_Dir = null then
               Harness_Dir := new String'(Attribute_Value (Proj, Attr));
            end if;
         end if;
      end;

      if not Output_M_Set then

         declare
            Attr1 : constant Attribute_Pkg_String :=
              Build (GT_Package, "subdir");
            Attr2 : constant Attribute_Pkg_String :=
              Build (GT_Package, "parallel_root");
         begin
            if
              Attribute_Value (Proj, Attr1) /= "" and
              Attribute_Value (Proj, Attr2) /= ""
            then
               Report_Err
                 ("invalid project file: " &
                  "subdir and separate root options are incompatible");
               raise Fatal_Error;
            end if;
            if Attribute_Value (Proj, Attr1) /= "" then
               Output_M := Subdir;
               Test_Subdir_Name := new String'(Attribute_Value (Proj, Attr1));
            end if;
            if Attribute_Value (Proj, Attr2) /= "" then
               Output_M := Separate_Root;
               Separate_Root_Dir := new String'(Attribute_Value (Proj, Attr1));
            end if;
         end;

      end if;

      if Additional_Tests_Prj = null then
         declare
            Attr : constant Attribute_Pkg_String :=
              Build (GT_Package, "additional_tests");
         begin
            if Attribute_Value (Proj, Attr) /= "" then
               Additional_Tests_Prj := new String'
                 (Attribute_Value (Proj, Attr));
            end if;
         end;
      end if;

      if not Default_Stubs_Set then
         declare
            Attr : constant Attribute_Pkg_String :=
              Build (GT_Package, "stubs_default");
         begin
            if Attribute_Value (Proj, Attr) /= "" then
               if Attribute_Value (Proj, Attr) = "pass" then
                  Stubs_Fail := False;
               elsif Attribute_Value (Proj, Attr) = "fail" then
                  Stubs_Fail := True;
               else
                  Report_Err
                    ("gnattest: stubs_default " &
                     "should be either fail or pass");
                  raise Parameter_Error;
               end if;
            end if;
         end;
      end if;

      declare
         Attr : constant Attribute_Pkg_List :=
           Build (GT_Package, "gnattest_switches");
         GT_Switches : String_List_Access;
      begin
         if Has_Attribute (Proj, Attr) then
            GT_Switches := Attribute_Value (Proj, Attr);
            for I in GT_Switches'Range loop
               if GT_Switches (I).all = "-r" then
                  Recursive_Sources := True;
               end if;
               if GT_Switches (I).all = "-q" then
                  Quiet := True;
               end if;
               if GT_Switches (I).all = "--liskov" then
                  Liskov_Suite := True;
               end if;
               if GT_Switches (I).all = "--harness-only" then
                  Harness_Only := True;
               end if;
               if GT_Switches (I).all = "-v" then
                  if not Verbose then
                     Verbose := True;
                     Print_Version_Info (2011);
                  end if;
               end if;
            end loop;
         end if;
      end;

   end Get_Gnattest_Specific_Attributes;

   ---------------------
   -- Get_Naming_Info --
   ---------------------

   procedure Get_Naming_Info
     (Source_Project_Tree : GNATCOLL.Projects.Project_Tree)
   is
      Project : Project_Type;
      Iterator        : Project_Iterator :=
        Start (Source_Project_Tree.Root_Project);

      Output_File : File_Type;

   begin
      Create (Output_File, Out_File, Config_Name);

      loop
         Project := Current (Iterator);
         exit when Project = No_Project;

         if Has_Attribute (Project, Spec_Attribute) then
            declare
               Atr_Indexes : constant GNAT.Strings.String_List :=
                 Attribute_Indexes (Project, Spec_Attribute);
            begin
               for I in Atr_Indexes'Range loop
                  Put_Line
                    (Output_File,
                     "pragma Source_File_Name (" &
                     Atr_Indexes (I).all         &
                     ",");
                  Put_Line
                    (Output_File,
                     "Spec_File_Name => """  &
                     Attribute_Value
                       (Project,
                        Spec_Attribute,
                        Atr_Indexes (I).all) &
                     """);");
               end loop;
            end;
         end if;

         if Has_Attribute (Project, Body_Attribute) then
            declare
               Atr_Indexes : constant GNAT.Strings.String_List :=
                 Attribute_Indexes (Project, Body_Attribute);
            begin
               for I in Atr_Indexes'Range loop
                  Put_Line
                    (Output_File,
                     "pragma Source_File_Name (" &
                     Atr_Indexes (I).all         &
                     ",");
                  Put_Line
                    (Output_File,
                     "Body_File_Name => """  &
                     Attribute_Value
                       (Project,
                        Body_Attribute,
                        Atr_Indexes (I).all) &
                     """);");
               end loop;
            end;
         end if;

         Next (Iterator);
      end loop;

      Close (Output_File);

   end Get_Naming_Info;

   -------------------------
   -- Is_Externally_Built --
   -------------------------
   function Is_Externally_Built (File : Virtual_File) return Boolean is
      F_Info : constant File_Info    := Info (Source_Project_Tree, File);
      Proj   : constant Project_Type := Project (F_Info);
      Attr   : constant Attribute_Pkg_String := Build ("", "externally_built");
   begin
      if Has_Attribute (Proj, Attr) then
         if Attribute_Value (Proj, Attr) = "true" then
            return True;
         end if;
      end if;
      return False;
   end Is_Externally_Built;

   ---------------------
   -- Initialize_Stub --
   ---------------------

   procedure Initialize_Stub is
   begin
      Scan_Parameters;
      Check_Parameters;
   exception
      when Parameter_Error =>
         --  The diagnosis is already generated
         raise Fatal_Error;
      when others =>
         Report_Err ("gnattest: initialization failed");
         --  Exception info will be generated in main driver
         raise;
   end Initialize_Stub;

   ---------------------------
   -- Non_Null_Intersection --
   ---------------------------

   function Non_Null_Intersection
     (Left  : File_Array_Access;
      Right : File_Array_Access) return Boolean is
   begin
      for J in Left'Range loop
         declare
            Left_Str : constant String :=
                         Normalize_Pathname
                           (Name => Left.all (J).Display_Full_Name,
                            Case_Sensitive => False);
         begin
            for K in Right'Range loop
               if Left_Str =
                 Normalize_Pathname
                   (Name => Right.all (K).Display_Full_Name,
                    Case_Sensitive => False)
               then
                  return True;
               end if;
            end loop;
         end;
      end loop;

      return False;
   end Non_Null_Intersection;

   -------------------------------------------
   -- Register_Gnattest_Specific_Attributes --
   -------------------------------------------

   procedure Register_Gnattest_Specific_Attributes is
      Dummy : String_Access;
   begin
      Dummy := new String'
        (Register_New_Attribute
           (Name => "harness_dir",
            Pkg  => "gnattest"));
      if Dummy.all /= "" then
         Report_Err ("gnattest: cannot parse project file");
         Report_Err (Dummy.all);
         raise Fatal_Error;
      end if;
      Free (Dummy);

      Dummy := new String'
        (Register_New_Attribute
           (Name => "subdir",
            Pkg  => "gnattest"));
      if Dummy.all /= "" then
         Report_Err ("gnattest: cannot parse project file");
         Report_Err (Dummy.all);
         raise Fatal_Error;
      end if;
      Free (Dummy);

      Dummy := new String'
        (Register_New_Attribute
           (Name => "separate_root",
            Pkg  => "gnattest"));
      if Dummy.all /= "" then
         Report_Err ("gnattest: cannot parse project file");
         Report_Err (Dummy.all);
         raise Fatal_Error;
      end if;
      Free (Dummy);

      Dummy := new String'
        (Register_New_Attribute
           (Name => "additional_tests",
            Pkg  => "gnattest"));
      if Dummy.all /= "" then
         Report_Err ("gnattest: cannot parse project file");
         Report_Err (Dummy.all);
         raise Fatal_Error;
      end if;
      Free (Dummy);

      Dummy := new String'
        (Register_New_Attribute
           (Name => "stubs_default",
            Pkg  => "gnattest"));
      if Dummy.all /= "" then
         Report_Err ("gnattest: cannot parse project file");
         Report_Err (Dummy.all);
         raise Fatal_Error;
      end if;
      Free (Dummy);

      Dummy := new String'
        (Register_New_Attribute
           (Name => "gnattest_switches",
            Pkg  => "gnattest",
            Is_List => True));
      if Dummy.all /= "" then
         Report_Err ("gnattest: cannot parse project file");
         Report_Err (Dummy.all);
         raise Fatal_Error;
      end if;
      Free (Dummy);

   end Register_Gnattest_Specific_Attributes;

   --------------------
   -- Scan_Dir_Affix --
   --------------------

   procedure Scan_Dir_Affix (Affix : String) is
      First_Idx : constant Integer := Affix'First;
      Last_Idx  : constant Integer := Affix'Last;
   begin
      for Idx in First_Idx .. Last_Idx loop
         if Affix (Idx) = '*' then
            Free (Test_Dir_Prefix);
            Test_Dir_Prefix := new String'(Affix (First_Idx .. Idx - 1));
            Free (Test_Dir_Suffix);
            Test_Dir_Suffix := new String'(Affix (Idx + 1 .. Last_Idx));
            return;
         end if;
      end loop;

      Report_Err ("gnattest: invalid parallel dir affix, should contain *");
      raise Parameter_Error;
   end Scan_Dir_Affix;

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

   procedure Scan_Parameters is
      Multiple_Output : Boolean := False;
   begin

      Initialize_Option_Scan
        (Stop_At_First_Non_Switch => False,
         Section_Delimiters       => "cargs");

      loop
         case GNAT.Command_Line.Getopt
           ("h d? P: q -separate-root= " &
            "-subdir= r v X? "           &
            "-harness-only "             &
            "-stub-default= "            &
            "-liskov "                   &
            "-additional-tests= "        &
            "-harness-dir=")
         is
            when ASCII.NUL =>
               exit;

            when 'd' =>
               if Full_Switch = "d" then
                  Set_Debug_Options (Parameter);
               end if;

            when 'P' =>
               Source_Prj := new String'(Parameter);

            when 'q' =>
               Quiet := True;

            when 'v' =>
               Verbose := True;

               Print_Version_Info (2011);

            when 'r' =>
               Recursive_Sources := True;

            when '-' =>
               if Full_Switch = "-additional-tests" then
                  Additional_Tests_Prj := new String'(Parameter);
               end if;

               if Full_Switch = "-stub-default" then
                  if Parameter = "pass" then
                     Stubs_Fail := False;
                     Default_Stubs_Set := True;
                  elsif Parameter = "fail" then
                     Stubs_Fail := True;
                     Default_Stubs_Set := True;
                  else
                     Report_Err
                       ("gnattest: --stub-default " &
                        "should be either fail or pass");
                     raise Parameter_Error;
                  end if;
               end if;

               if Full_Switch = "-separate-root" then
                  if not Multiple_Output then
                     Output_M := Separate_Root;
                     Output_M_Set := True;
                     Separate_Root_Dir := new String'(Parameter);
                     Multiple_Output := True;
                  else
                     Report_Err
                       ("gnattest: multiple output modes are not allowed");
                     raise Parameter_Error;
                  end if;
               end if;

               --  Hidden from usage due to overengineering.
               if Full_Switch = "-parallel" then
                  if not Multiple_Output then
                     Output_M := Parallel;
                     Output_M_Set := True;
                     Scan_Dir_Affix (Parameter);
                     Multiple_Output := True;
                  else
                     Report_Err
                       ("gnattest: multiple output modes are not allowed");
                     raise Parameter_Error;
                  end if;
               end if;

               if Full_Switch = "-subdir" then

                  if not Multiple_Output then
                     Output_M := Subdir;
                     Output_M_Set := True;
                     Test_Subdir_Name := new String'(Parameter);
                     Multiple_Output := True;
                  else
                     Report_Err
                       ("gnattest: multiple output modes are not allowed");
                     raise Parameter_Error;
                  end if;

               end if;

               if Full_Switch = "-liskov" then
                  Liskov_Suite := True;
               end if;

               if Full_Switch = "-harness-dir" then
                  Harness_Dir := new String'(Parameter);
               end if;

               if Full_Switch = "-harness-only" then
                  Harness_Only := True;
               end if;

            when 'X' =>
               Ext_Var_Buffer.Append (Parameter);

            when others =>
               Brief_Help;
               raise Parameter_Error;
         end case;
      end loop;

      loop
         declare
            Temp : constant String := Get_Argument;
         begin
            if Temp = "" then
               exit;
            end if;
            Source_Buffer.Append (Temp);
         end;
      end loop;

      Process_cargs_Section;

   exception
      when GNAT.Command_Line.Invalid_Switch =>
         Report_Err ("gnattest: invalid switch : " & Full_Switch);
         Brief_Help;

         raise Parameter_Error;

      when GNAT.Command_Line.Invalid_Parameter =>
         Report_Err ("gnattest: missing parameter for: -" & Full_Switch);
         Brief_Help;

         raise Parameter_Error;
   end Scan_Parameters;

end GNATtest.Environment;
