------------------------------------------------------------------------------
--                                                                          --
--                           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-2014, 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.Containers.Indefinite_Ordered_Sets;

with Asis.Ada_Environments;      use Asis.Ada_Environments;

with Ada.Strings.Fixed;          use Ada.Strings.Fixed;

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.Skeleton.Source_Table;    use GNATtest.Skeleton.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_Skeletons_Set : Boolean := False;
   Show_Passed_Tests_Set : Boolean := False;

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

   Env   : Project_Environment_Access;

   Recursive_Sources : Boolean := False;

   Object_Dir : String_Access;

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

   Gnatls_To_Call : String_Access;
   Default_RTS    : 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.

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

   procedure Check_Stub;
   --  Checks if there are no intersections between stub and source dirs and
   --  between stub and test dirs.

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

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

   function Has_Command_Line_Support (Runtime_Name : String) return Boolean;
   --  Checks whether the name passed as parameter corresponds to a run-time
   --  library with command line support or not.

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

   procedure Add_Test_Paths is
      Tmp : String_Access;
   begin
      GNATtest.Skeleton.Source_Table.Reset_Source_Iterator;
      loop
         Tmp := new String'(GNATtest.Skeleton.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.Skeleton.Source_Table.Reset_Location_Iterator;

         loop
            Tmp := new String'(Normalize_Pathname
              (Name           =>
                 GNATtest.Skeleton.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 " &
                "[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 ("");
      Put_Line (" --additional-tests=prjname - sources " &
                "described in projname are considered");
      Put_Line ("                              potential " &
                "additional manual tests to be added");
      Put_Line ("                              to the test suite.");

      Put_Line ("");
      Put_Line (" --harness-dir=dirname   - output dir for test harness");

      Put_Line ("");
      Put_Line (" --tests-dir=dirname  - " &
                "test files are put in dirname");
      Put_Line (" --subdir=dirname     - " &
                "test files are put in the dirname subdirectories");
      Put_Line ("                        " &
                "located at the same level as source files");
      Put_Line (" --tests-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 (" --validate-type-extensions     - " &
                "run all tests from all parents in order");
      Put_Line ("                                  " &
                "to check substitutability.");
      Put_Line (" --skeleton-default=(pass|fail) - sets default behavior " &
                  "of unimplemented tests");
      Put_Line (" --passed-tests=(show|hide)     - sets default output " &
                "of passed tests");
      Put_Line ("");
      Put_Line (" --harness-only - all argument sources are treated as tests");
      Put_Line ("                  to be added to the suite");

   end Brief_Help;

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

   procedure Check_Parameters is

      Tmp : String_Access;

      --  Project support:
      Files : File_Array_Access;
      V_F   : Virtual_File;

      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.
      --  Sets Options.No_Comand_Line depending of default value of
      --  AUnit_Shared.Runtime.

      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;
      --  Sets values of external variables passed to gnattest by -X options.
      --  Overwrites the value of Options.No_Comand_Line if RUNTIME is among
      --  scenario variables declared in the project or passed to the tool.

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

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

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

      procedure Add_AUnit_Paths is
         Output_File : File_Type;
         SPT : GNATCOLL.Projects.Project_Tree;

         Platform_Set : Boolean := False;
         Runtime_Set  : Boolean := False;
      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);

         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
               if S'Length > 8 then
                  if S (F_Idx .. F_Idx + 7) = "RUNTIME=" then
                     Setenv ("RUNTIME", S (F_Idx + 8 .. L_Idx));
                     Runtime_Set := True;
                  end if;
               end if;
               if S'Length > 9 then
                  if S (F_Idx .. F_Idx + 8) = "PLATFORM=" then
                     Setenv ("PLATFORM", S (F_Idx + 9 .. L_Idx));
                     Platform_Set := True;
                  end if;
               end if;
            end;

            List_Of_Strings.Next (SB_Cur);
         end loop;

         if not Platform_Set then
            if Base_Name (Gnatls_To_Call.all) /= "gnatls" then
               declare
                  Tmp : constant String := (Base_Name (Gnatls_To_Call.all));
               begin
                  Setenv ("PLATFORM", Tmp (Tmp'First .. Tmp'Last - 7));
               end;
            end if;
         end if;

         if not Runtime_Set then
            if Base_Name (Gnatls_To_Call.all) /= "gnatls" then
               Setenv ("RUNTIME", Default_RTS.all);
            end if;
         end if;

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

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

         declare
            Vars : constant Scenario_Variable_Array :=
              Source_Project_Tree.Scenario_Variables;
         begin
            for I in Vars'Range loop
               if External_Name (Vars (I)) = "RUNTIME" then
                  No_Command_Line :=
                    not Has_Command_Line_Support (Value (Vars (I)));
                  exit;
               end if;
            end loop;
         end;

         SPT.Unload;

      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;

         Platform_Set_Externally : Boolean := False;
         Runtime_Set_Externally  : Boolean := False;
      begin

         for I in Vars'Range loop
            if External_Name (Vars (I)) = "RUNTIME" then
               No_Command_Line :=
                 not Has_Command_Line_Support (External_Default (Vars (I)));
               exit;
            end if;
         end loop;

         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;

            if Var_Name.all = "RUNTIME" then
               No_Command_Line := not Has_Command_Line_Support (Var_Val.all);
               Runtime_Set_Externally := True;
            end if;

            if Var_Name.all = "PLATFORM" then
               Platform_Set_Externally := True;
            end if;

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

         if not Runtime_Set_Externally then
            if Base_Name (Gnatls_To_Call.all) /= "gnatls" then
               declare
                  Runtime : Scenario_Variable :=
                    Scenario_Variables (Source_Project_Tree, "RUNTIME");
               begin
                  Set_Value (Runtime, Default_RTS.all);
                  No_Command_Line :=
                    not Has_Command_Line_Support (Default_RTS.all);
               end;
            end if;
         end if;

         if not Platform_Set_Externally then
            if Base_Name (Gnatls_To_Call.all) /= "gnatls" then
               declare
                  Platform : Scenario_Variable :=
                    Scenario_Variables (Source_Project_Tree, "PLATFORM");
                  Tmp : constant String := (Base_Name (Gnatls_To_Call.all));
               begin
                  Set_Value (Platform, Tmp (Tmp'First .. Tmp'Last - 7));
               end;
            end if;
         end if;

         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_Asis_Mode
        (Source_Project_Tree : GNATCOLL.Projects.Project_Tree)
      is
         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
            if
              Switches (I).all = "-gnat95"
            then
               ASIS_UL.Compiler_Options.Store_Option ("-gnat95");
            end if;
            if
              Switches (I).all = "-gnat2005" or else
              Switches (I).all = "-gnat05"
            then
               ASIS_UL.Compiler_Options.Store_Option ("-gnat05");
            end if;
            if
              Switches (I).all = "-gnat12" or else
              Switches (I).all = "-gnat2012"
            then
               ASIS_UL.Compiler_Options.Store_Option ("-gnat12");
            end if;
         end loop;
      end Set_Asis_Mode;

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

      --  looking for default runtime
      if Base_Name (Gnatls_To_Call.all) /= "gnatls" then
         declare
            Gnatls_Output :          File_Type;
            Args          : constant Argument_List :=
              (1 => new String'("-v"));
            Return_Code   :          Integer := 0;
            Success       :          Boolean := True;
            Tmp           :          String_Access;
            Idx1, Idx2    :          Natural;
         begin
            Spawn
              (Gnatls_To_Call.all,
               Args,
               "gnatls_output",
               Success,
               Return_Code);
            Open (Gnatls_Output, In_File, "gnatls_output");

            while not End_Of_File (Gnatls_Output) loop
               Tmp := new String'(Get_Line (Gnatls_Output));

               Idx1 := Index (Tmp.all, "adainclude");
               if Idx1 /= 0 then
                  Idx2 := Index (Tmp.all, "rts-");
                  Default_RTS := new String'(Tmp (Idx2 + 4 .. Idx1 - 2));
                  Free (Tmp);
                  exit;
               end if;

               Free (Tmp);
            end loop;

            Close (Gnatls_Output);
         end;
      end if;

      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;

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

         Object_Dir := new String'
           (Source_Project_Tree.Root_Project.Object_Dir.Display_Full_Name);

         --  Checking if argument project has IDE package specified.
         declare
            S : constant Attribute_Pkg_String := Build (Ide_Package, "");
         begin
            if Has_Attribute (Source_Project_Tree.Root_Project, S) then
               IDE_Package_Present := True;
            else
               IDE_Package_Present := False;
            end if;
         end;

         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");
         raise Parameter_Error;
      end if;

      --  need to check if given file is a source file of argument project
      Files := new File_Array'
        (Source_Project_Tree.Root_Project.Source_Dirs (True));

      SB_Cur := Source_Buffer.First;
      loop

         exit when SB_Cur = List_Of_Strings.No_Element;

         V_F := Locate_Regular_File
           (+(Base_Name (List_Of_Strings.Element (SB_Cur))),
            Files.all);

         if V_F = No_File then
            Report_Err
              (Base_Name (List_Of_Strings.Element (SB_Cur))
               & " is not part of "
               & Base_Name (Source_Prj.all)
               & " or its dependencies");
         else

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

         end if;

         List_Of_Strings.Next (SB_Cur);
      end loop;

      Source_Buffer.Clear;

      if Harness_Dir /= null then

         if not Is_Absolute_Path (GNATCOLL.VFS.Create (+Harness_Dir.all)) then
            Tmp := new String'(Object_Dir.all & Harness_Dir.all);
            Free (Harness_Dir);
            Harness_Dir := Tmp;
            Tmp := null;
         end if;

         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

            declare
               Dir : File_Array_Access;
            begin
               Append (Dir, GNATCOLL.VFS.Create (+Harness_Dir.all));
               Create_Dirs (Dir);
            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);
         Set_Asis_Mode (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");
               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");
                  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);
                     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");
                  raise Parameter_Error;
               end if;

            end if;

         end if;
      else

         if GNATtest.Skeleton.Source_Table.SF_Table_Empty then
            if Source_Prj.all = "" then
               Report_Err ("No input source file set");
               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.Skeleton.Source_Table.Add_Source_To_Process
                          (Files (F).Display_Full_Name);
                     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.Skeleton.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;
            when Direct =>
               Check_Direct;
         end case;

         if Stub_Mode_ON then
            Check_Stub;
         end if;
      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);
               end if;
            end if;
         end loop;

      end if;

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

      --  Disregard the fact that Process_cargs_Section calls Set_Arg_List and
      --  Process_ADA_PRJ_INCLUDE_FILE already, whithout their explicit call
      --  compiltaion dependancies for sources from imported projects are not
      --  resolved.
      --  Thay cannot be replaced with Process_cargs_Section here.
      Process_ADA_PRJ_INCLUDE_FILE;
      Store_I_Options;
      Set_Arg_List;

      Free (Env);
   end Check_Parameters;

   ------------------
   -- Check_Direct --
   ------------------

   procedure Check_Direct is
      Tmp : String_Access;
      TD_Name : constant Virtual_File :=
        GNATCOLL.VFS.Create (+Test_Dir_Name.all);
      Future_Dirs : File_Array_Access := new File_Array'(Empty_File_Array);

      Obj_Dir : String_Access;

      Project  : Project_Type;
      Iterator : Project_Iterator :=
        Start (Source_Project_Tree.Root_Project);
   begin

      if TD_Name.Is_Absolute_Path then
         Append (Future_Dirs, GNATCOLL.VFS.Create (+Test_Dir_Name.all));
      else
         loop
            Project := Current (Iterator);
            exit when Project = No_Project;

            Obj_Dir := new String'(Project.Object_Dir.Display_Full_Name);
            Tmp := new String'(Obj_Dir.all & Test_Dir_Name.all);
            Append (Future_Dirs, GNATCOLL.VFS.Create (+Tmp.all));
            Free (Tmp);
            Free (Obj_Dir);

            Next (Iterator);
         end loop;
      end if;

      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;

      Set_Direct_Output;
   end Check_Direct;

   ----------------
   -- Check_Stub --
   ----------------

   procedure Check_Stub is
      Tmp : String_Access;
      SD_Name : constant Virtual_File :=
        GNATCOLL.VFS.Create (+Stub_Dir_Name.all);
      Future_Dirs : File_Array_Access := new File_Array'(Empty_File_Array);

      Obj_Dir : String_Access;

      Project  : Project_Type;
      Iterator : Project_Iterator :=
        Start (Source_Project_Tree.Root_Project);
   begin

      --  look for collisions with source dirs
      if SD_Name.Is_Absolute_Path then
         Append (Future_Dirs, GNATCOLL.VFS.Create (+Test_Dir_Name.all));
      else
         loop
            Project := Current (Iterator);
            exit when Project = No_Project;

            Obj_Dir := new String'(Project.Object_Dir.Display_Full_Name);
            Tmp := new String'(Obj_Dir.all & Stub_Dir_Name.all);
            Append (Future_Dirs, GNATCOLL.VFS.Create (+Tmp.all));
            Free (Tmp);
            Free (Obj_Dir);

            Next (Iterator);
         end loop;
      end if;

      if Non_Null_Intersection (Future_Dirs, All_Source_Locations) then
         Report_Err ("gnattest: invalid stub directory, cannot mix up "
                     & "stubs and source files");
         raise Parameter_Error;
      end if;

      Set_Direct_Stub_Output;

      --  Once stub dirs are set we can compare them with test dirs per source.
      Skeleton.Source_Table.Reset_Source_Iterator;
      Tmp := new String'(Skeleton.Source_Table.Next_Source_Name);
      while Tmp.all /= "" loop
         if
           Skeleton.Source_Table.Get_Source_Output_Dir (Tmp.all) =
           Skeleton.Source_Table.Get_Source_Stub_Dir (Tmp.all)
         then
            Report_Err ("gnattest: invalid stub directory, cannot mix up "
                        & "stubs and tests");
            raise Parameter_Error;
         end if;
         Free (Tmp);
         Tmp := new String'(Skeleton.Source_Table.Next_Source_Name);
      end loop;

      Skeleton.Source_Table.Reset_Source_Iterator;
   end Check_Stub;

   --------------------
   -- 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.Skeleton.Source_Table.Reset_Location_Iterator;

      loop
         Tmp := new String'
           (GNATtest.Skeleton.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;

      Set_Parallel_Output;
   end Check_Parallel;

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

   procedure Check_Separate_Root is

      RD_Name : constant Virtual_File :=
        GNATCOLL.VFS.Create (+Separate_Root_Dir.all);

      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.

      Files : File_Array_Access;
      Project  : Project_Type;
      Iterator : Project_Iterator :=
        Start (Source_Project_Tree.Root_Project);
      Obj_Dir                 : String_Access;
      Local_Separate_Root_Dir : String_Access;

      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
               return Left (Left'First .. Last_Dir_Sep_Index);
            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

      if RD_Name.Is_Absolute_Path then

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

         loop
            Tmp := new String'
              (GNATtest.Skeleton.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;

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

         GNATtest.Skeleton.Source_Table.Reset_Location_Iterator;

         loop
            Tmp := new String'
              (GNATtest.Skeleton.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;

         Set_Separate_Root (Maximin_Root.all);
      else

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

            Files := Project.Source_Files;

            if Files'Length > 0 then
               Maximin_Root := new String'
                 (Files (Files'First).Display_Dir_Name);

               for F in Files'Range loop
                  Tmp := new String'(Files (F).Display_Dir_Name);
                  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;

               Obj_Dir := new String'(Project.Object_Dir.Display_Full_Name);

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

               for F in Files'Range loop

                  if
                    Source_Project_Tree.Info (Files (F)).Unit_Part = Unit_Spec
                  then
                     Tmp := new String'(Files (F).Display_Dir_Name);

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

                     Set_Output_Dir
                       (Files (F).Display_Full_Name,
                        Local_Separate_Root_Dir.all & Directory_Separator &
                        Tmp.all (Root_Length + 1 .. Tmp.all'Last));
                  end if;

               end loop;

            end if;

            Next (Iterator);
         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;

      end if;

   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.Skeleton.Source_Table.Reset_Location_Iterator;

      loop
         Tmp := new String'
           (GNATtest.Skeleton.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;

      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_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 not Harness_Set_By_Switch 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, "tests_root");
            Attr3 : constant Attribute_Pkg_String :=
              Build (GT_Package, "tests_dir");

            Output_Attr_Counter : Natural := 0;
         begin
            if Attribute_Value (Proj, Attr1) /= "" then
               Output_Attr_Counter := Output_Attr_Counter + 1;
            end if;
            if Attribute_Value (Proj, Attr2) /= "" then
               Output_Attr_Counter := Output_Attr_Counter + 1;
            end if;
            if Attribute_Value (Proj, Attr3) /= "" then
               Output_Attr_Counter := Output_Attr_Counter + 1;
            end if;

            if Output_Attr_Counter > 1 then
               Report_Err
                 ("invalid project file: " &
                  "more than one output mode specified");
               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, Attr2));
            end if;
            if Attribute_Value (Proj, Attr3) /= "" then
               Output_M := Direct;
               Test_Dir_Name := new String'(Attribute_Value (Proj, Attr3));
            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_Skeletons_Set then
         declare
            Attr : constant Attribute_Pkg_String :=
              Build (GT_Package, "skeletons_default");
         begin
            if Attribute_Value (Proj, Attr) /= "" then
               if Attribute_Value (Proj, Attr) = "pass" then
                  Skeletons_Fail := False;
               elsif Attribute_Value (Proj, Attr) = "fail" then
                  Skeletons_Fail := True;
               else
                  Report_Err
                    ("gnattest: skeletons_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 = "--validate-type-extensions" then
                  Substitution_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;
               if not Show_Passed_Tests_Set then
                  if GT_Switches (I).all = "--passed-tests=show" then
                     Show_Passed_Tests := True;
                  end if;
                  if GT_Switches (I).all = "--passed-tests=hide" then
                     Show_Passed_Tests := False;
                  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;

      Sources : constant File_Array_Access :=
        Source_Project_Tree.Root_Project.Source_Files (Recursive => True);

      package Specific_Sources_Set is new
        Ada.Containers.Indefinite_Ordered_Sets (String);
      use Specific_Sources_Set;

      Specific_Sources : Specific_Sources_Set.Set;
      Cur : Specific_Sources_Set.Cursor;

      function File_To_Unit
        (File : String; Suff : String; Dot : String) return String;

      function File_To_Unit
        (File : String; Suff : String; Dot : String) return String
      is
         Name : constant String :=
           File (File'First .. File'Last - Suff'Length);
         Idx        :          Integer := Name'First;
         Dot_Length : constant Integer := Dot'Length;

         Tmp : String_Access;
         Res : String_Access := new String'("");
      begin

         for I in Name'Range loop

            if I + Dot_Length <= Name'Last then
               if Name (I .. I + Dot_Length) = Dot then

                  if Res.all = "" then
                     Free (Res);
                     Res := new String'(Name (Idx .. I - 1));
                  else
                     Tmp := new String'(Res.all & "." & Name (Idx .. I - 1));
                     Free (Res);
                     Res := Tmp;
                     Tmp := null;
                  end if;
                  Idx := Idx + Dot_Length;

               end if;
            end if;

            if I = Name'Last then
               Tmp := new String'(Res.all & Name (Idx .. I));
               Free (Res);
               Res := Tmp;
               Tmp := null;
            end if;

         end loop;

         return Res.all;
      end File_To_Unit;

   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) &
                     """);");
                  Specific_Sources.Include
                    (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) &
                     """);");
                  Specific_Sources.Include
                    (Attribute_Value
                       (Project,
                        Spec_Attribute,
                        Atr_Indexes (I).all));
               end loop;
            end;
         end if;

         Next (Iterator);
      end loop;

      for F in Sources'Range loop

         if
           Source_Project_Tree.Info (Sources (F)).Unit_Part = Unit_Spec
         then
            Cur := Specific_Sources.Find (Sources (F).Display_Base_Name);

            if Cur = Specific_Sources_Set.No_Element then

               Project :=
                 GNATCOLL.Projects.Project
                   (Source_Project_Tree.Info (Sources (F)));
               declare
                  Suffix  : constant String :=
                    Attribute_Value (Project, Spec_Suffix_Attribute, "ada");
                  Dot_Rep : constant String :=
                    Attribute_Value
                      (Project, Dot_Replacement_Attribute, "ada");
               begin
                  if Suffix /= ".ads" or else Dot_Rep /= "-" then

                     Put_Line
                       (Output_File,
                        "pragma Source_File_Name (" &
                        File_To_Unit
                          (Sources (F).Display_Base_Name,
                           Suffix, Dot_Rep) &
                        ",");
                     Put_Line
                       (Output_File,
                        "Spec_File_Name => """  &
                        Sources (F).Display_Base_Name &
                        """);");

                  end if;
               end;

            end if;

         end if;

      end loop;

      Close (Output_File);

      Specific_Sources.Clear;

   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 --
   ----------------

   procedure Initialize 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;

   ---------------------------
   -- 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 => "tests_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 => "tests_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 => "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 => "skeletons_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 -tests-root= "
            & "-help -version "
            & "-separates "
            & "-no-separates "
            & "-transition "
            & "-subdir= r v X? "
            & "-harness-only "
            & "-stub "
            & "-skeleton-default= "
            & "-passed-tests= "
            & "-validate-type-extensions "
            & "-additional-tests= "
            & "-harness-dir= "
            & "-tests-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 = "-passed-tests" then
                  if Parameter = "hide" then
                     Show_Passed_Tests := False;
                     Show_Passed_Tests_Set := True;
                  elsif Parameter = "show" then
                     Show_Passed_Tests := True;
                     Show_Passed_Tests_Set := True;
                  else
                     Report_Err
                       ("gnattest: --passed-tests " &
                        "should be either show or hide");
                     raise Parameter_Error;
                  end if;
               end if;

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

               if Full_Switch = "-tests-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 = "-tests-dir" then

                  if not Multiple_Output then
                     Output_M := Direct;
                     Output_M_Set := True;
                     Test_Dir_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 = "-validate-type-extensions" then
                  Substitution_Suite := True;
               end if;

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

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

               if Full_Switch = "-separates" then
                  Generate_Separates := True;
               end if;

               if Full_Switch = "-no-separates" then
                  Generate_Separates := False;
               end if;

               if Full_Switch = "-transition" then
                  Transition := True;
               end if;

               if Full_Switch = "-stub" then
                  Stub_Mode_ON := True;
               end if;

               if Full_Switch = "-version" then
                  Print_Version_Info (2011);
                  raise Parameter_Error;
               end if;

               if Full_Switch = "-help" then
                  Brief_Help;
                  raise Parameter_Error;
               end if;

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

            when others =>
               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);
         Report_Err ("Try `gnattest --help` for more information.");

         raise Parameter_Error;

      when GNAT.Command_Line.Invalid_Parameter =>
         Report_Err ("gnattest: missing parameter for: -" & Full_Switch);
         Report_Err ("Try `gnattest --help` for more information.");

         raise Parameter_Error;
   end Scan_Parameters;

   ------------------------------
   -- Has_Command_Line_Support --
   ------------------------------

   function Has_Command_Line_Support (Runtime_Name : String) return Boolean is
   begin
      return Runtime_Name /= "zfp" and then
             Runtime_Name /= "cert" and then
             Runtime_Name /= "ravenscar" and then
             Runtime_Name /= "ravenscar-full" and then
             Runtime_Name /= "ravenscar-cert" and then
             Runtime_Name /= "ravenscar-sfp" and then
             Runtime_Name /= "ravenscar-cert-rtp";
   end Has_Command_Line_Support;

end GNATtest.Environment;
