asis_2019.0.0_3ca32fa2/tools/gnattest/gnattest-harness-generator.adb

------------------------------------------------------------------------------
--                                                                          --
--                           GNATTEST COMPONENTS                            --
--                                                                          --
--           G N A T T E S T . H A R N E S S . G E N E R A T O R            --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2011-2019, 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).              --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2012;

with Ada.Containers;             use Ada.Containers;
with Ada.Containers.Indefinite_Ordered_Sets;
with Ada.Containers.Vectors;

with Ada.Characters.Handling;    use Ada.Characters.Handling;
with Ada.Strings;                use Ada.Strings;
with Ada.Strings.Fixed;          use Ada.Strings.Fixed;
with GNAT.Directory_Operations;  use GNAT.Directory_Operations;

with Asis.Ada_Environments;      use Asis.Ada_Environments;
with Asis.Compilation_Units;     use Asis.Compilation_Units;
with Asis.Declarations;          use Asis.Declarations;
with Asis.Definitions;           use Asis.Definitions;
with Asis.Elements;              use Asis.Elements;
with Asis.Extensions;            use Asis.Extensions;
with Asis.Errors;
with Asis.Exceptions;            use Asis.Exceptions;
with Asis.Expressions;           use Asis.Expressions;
with Asis.Implementation;
with Asis.Iterator;              use Asis.Iterator;
with Asis.Text;                  use Asis.Text;

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

with GNATtest.Harness.Source_Table;  use GNATtest.Harness.Source_Table;
with GNATtest.Options;               use GNATtest.Options;
with GNATtest.Environment;           use GNATtest.Environment;
with GNATtest.Skeleton.Source_Table;

with GNATCOLL.VFS;                use GNATCOLL.VFS;
with GNATCOLL.VFS_Utils;          use GNATCOLL.VFS_Utils;
with GNATCOLL.Traces;             use GNATCOLL.Traces;

package body GNATtest.Harness.Generator is

   Me : constant Trace_Handle := Create ("Harness", Default => Off);

   use List_Of_Strings;
   use Asis_Element_List;

   Suit_List : List_Of_Strings.List;
   --  Storing the names of all suits

   Good_For_Substitution_Inst : List_Of_Strings.List;
   --  Storing the names of generic test packages, that should have
   --  a substitution suite instance.

   Last_Context_Name : String_Access;
   --  Suffixless name of the last tree file created

   type Separate_Project_Info is record
      Name_TD          : String_Access := null;
      Name_Extending   : String_Access := null;
      Path_TD          : String_Access := null;
      Path_Extending   : String_Access := null;
      Name_Of_Extended : String_Access := null;
      Path_Of_Extended : String_Access := null;
      Main_File_Name   : String_Access := null;
      Stub_Source_Dir  : String_Access := null;
      Test_Package     : String_Access := null;
      Test_Data        : String_Access := null;
      UUT_File_Name    : String_Access := null;
      Sources_List     : List_Of_Strings.List := List_Of_Strings.Empty_List;
   end record;

   package Separate_Project_Info_Vestors is new
     Ada.Containers.Vectors (Positive, Separate_Project_Info);
   use Separate_Project_Info_Vestors;

   Separate_Projects : Separate_Project_Info_Vestors.Vector;

   ------------------------
   --  String constants  --
   ------------------------

   --  Unit names:

   Common_Suite_Name          : constant String := "Suite";
   --  Suffixless name of the unit containing a common suite

   Generic_Suite_Name         : constant String := "Gen_Suite";
   --  Suffixless name of the unit containing a generic suite

   Substitution_Suite_Name    : constant String := "Substitution_Suite";
   --  Suffixless name of the unit containing substitution suite

   Generic_Substitution_Suite_Name  : constant String
     := "Gen_Substitution_Suite";
   --  Suffixless name of the unit containing a generic substitution suite

   Instant_Suite_Name         : constant String := "Suite_Inst";
   --  Suffixless name of the unit containing instantination suite

   Substitution_Instant_Suite_Name  : constant String
     := "Substitution_Suite_Inst";
   --  Suffixless name of the unit containing instantination suite

   --  Infrastructure elements:

   Test_Case_Prefix           : constant String := "Case_";
   --  Prefix to Test_Case variables' names

   Main_Suite_Name            : constant String := "Gnattest_Main_Suite";
   --  Suffixless name of the unit containing the main suite

   Test_Runner_Name           : constant String := "Test_Runner";
   --  Suffixless name of the unit containing the test runner

   -------------------------
   --  Inner Subprograms  --
   -------------------------

   function Initialize_Context (Source_Name : String) return Boolean;
   --  Creates a tree file and initializes the context.

   procedure Create_Tree (Full_Source_Name : String; Success : out Boolean);
   --  Tries to create the tree file for the given source file. The tree file
   --  and the corresponding ALI file are placed into a temporary directory.
   --  If the attempt is successful, Success is set ON, otherwise it is set
   --  OFF.

   procedure Process_Source (The_Unit : Asis.Compilation_Unit);
   --  Processes given compilation unit, gathers information that is needed
   --  for generating the testing unit and suite and calls their generators
   --  if the source is appropriate (contains one or less tagged recors test
   --  type declaration and at least one test routine).

   procedure Gather_Data
     (The_Unit          : Asis.Compilation_Unit;
      Data              : in out Data_Holder;
      Apropriate_Source : out Boolean);
   --  Iterates through the given unit and sets the values of Main_Type and
   --  Subp_List. All the iterations are done here.
   --  Checks if given unit is of the right kind and if it is appropriate.
   --  Marks unappropriate sources in the source table.

   procedure Gather_Liskiv_Data (Data : in out Data_Holder);
   --  Gathers data about overriden test routines.

   function Root_Type_Declaration
     (Type_Dec : Asis.Element) return Asis.Element;
   --  Unlike Corresponding_Root_Type unwinds all the tagged record type
   --  hierarchy disregart the privacy of intermidiate extensions.
   --  If the argument allready is a record type declaration, returns itself.
   --  If given not a tagged record declaration or extension declaration
   --  returns Nil_Element.

   function Parent_Type_Declaration
     (Type_Dec : Asis.Element) return Asis.Element;
   --  Returns a corresponding parent type declaration for a given tagged type
   --  extension declaration.

   function Corresponding_Generic_Package
     (Package_Instance : Asis.Element) return Asis.Element;
   --  Returns a corresponding generic package declaration for a
   --  formal package.

   function Is_AUnit_Part (Unit : Compilation_Unit) return Boolean;
   --  Checks if the unit under consideration is a part of AUnit library itself

   function Is_Test_Routine (Subp : Asis.Element) return Boolean;
   --  Indicates if the given Subprogram is a test routine, which means it
   --  has only one parameter whose type is a descendant of AUnit test type.
   --  Also returns False for Set_Up, Set_Up_Case, Tear_Down, Tear_Down_Case.

   function Is_Test_Fixture_Routine (Subp : Asis.Element) return Boolean;
   --  Same as above, but only returns true if the ancestor test type is
   --  Test_Fixture.

   function Is_Test_Related (Subp : Asis.Element) return Boolean;
   --  Indicates if the given Subprogram is of interest, that is a test routine
   --  or Set_Up/Tear_Down etc.

   function Is_Test_Case (Type_Decl : Asis.Element) return Boolean;
   --  Indicates if given type is a test_case type of AUnit framework.

   procedure Generate_Substitution_Suite_From_Tests (Data : Data_Holder);
   --  Creates a substitution test suite.

   procedure Generate_Suite_Instance (Data : Data_Holder);
   --  Creates a suite instantination.

   function Get_Subp_Name (Subp : Asis.Element) return String;
   --  Returns a name of the subprogram whose declaration is given as Subp.

   procedure Source_Clean_Up;
   --  Minimal clean-up needed for one source (deleting .ali & .adt)

   function Positive_Image (P : Positive) return String;
   --  Returns a trimmed image of the argument

   function Nesting_Difference
     (Nesting_1, Nesting_2 : String) return String;
   --  Returns difference in ending of two nestings without the first dot
   --  of the deeper nesting.

   procedure Generate_Common_Harness_Files;
   --  Generates aggregate project and a makefile for separate drivers
   --  and test_drivers.list.

   procedure Generate_Global_Config_Pragmas_File;
   --  Generates files containing pragmas suppressing pre and postconditions
   --  and possibly manipulating ghost policy.

   procedure Generate_Gnattest_Common_Prj;
   --  Generates abstract project file gnattest_common that contains different
   --  attributes relevant to the harness.

   function Gnattest_Common_Prj_Name return String is
      (Harness_Dir.all & Directory_Separator & "gnattest_common.gpr");

   function Type_Test_Package (Elem : Asis.Element) return String;
   --  Get name of test package where test type corresponding to Elem should be
   --  declared.

   function Type_Name (Elem : Asis.Element) return String is
     (To_String (Defining_Name_Image (First_Name (Elem))));

   -----------------
   -- Create_Tree --
   -----------------

   procedure Create_Tree (Full_Source_Name : String; Success : out Boolean) is
   begin
      Compile
       (new String'(Full_Source_Name),
        Arg_List.all,
        Success,
        GCC          => ASIS_UL.Common.Gcc_To_Call,
        Display_Call => ASIS_UL.Debug.Debug_Flag_C);
   end Create_Tree;

   -------------------------------------
   --  Corresponding_Generic_Package  --
   -------------------------------------
   function Corresponding_Generic_Package
     (Package_Instance : Asis.Element) return Asis.Element
   is
      Name : constant Asis.Element := First_Name (Package_Instance);
   begin
      return
        Unit_Declaration (Library_Unit_Declaration (Defining_Name_Image
          (Corresponding_Generic_Element (Name)), The_Context));
   end Corresponding_Generic_Package;

   -------------------
   --  Gather_Data  --
   -------------------

   procedure Gather_Data
     (The_Unit          : Asis.Compilation_Unit;
      Data              : in out Data_Holder;
      Apropriate_Source : out Boolean) is separate;

   --------------------------
   --  Gather_Liskiv_Data  --
   --------------------------

   procedure Gather_Liskiv_Data (Data : in out Data_Holder) is

      Test_Routine : Test_Routine_Info_Enhanced;

      Subp            : Asis.Element;
      Overridden_Subp : Asis.Element;
      Original_Type   : Asis.Element;
      Unit_Im         : String_Access;

      Type_Number : Positive;
      Depth       : Natural;

      Parent_Unit :  Asis.Compilation_Unit;
      Parent_File : String_Access;

      Tmp_Type_Info : Test_Type_Info;

   begin

      for K in 1 .. To_Index (Data.TR_List.Last) loop

         Subp        := Data.TR_List.Element (K).TR_Declaration;
         Type_Number := Data.TR_List.Element (K).Test_Type_Numb;

         if Is_Overriding_Operation (Subp) then
            Overridden_Subp := Corresponding_Overridden_Operation (Subp);
            Original_Type   := Enclosing_Element (Primitive_Owner (Subp));

            if Is_Part_Of_Inherited (Overridden_Subp) then
               Overridden_Subp :=
                 Corresponding_Declaration (Overridden_Subp);
            end if;

            Unit_Im := new String'(Base_Name (To_String (Text_Name
              (Enclosing_Compilation_Unit (Overridden_Subp)))));

            if
              Trait_Kind (Overridden_Subp) /= An_Abstract_Trait and
              Source_Present (Unit_Im.all)
            then

               Test_Routine.TR_Declaration      := Overridden_Subp;
               Test_Routine.TR_Text_Name        :=
                 new String'(Get_Subp_Name (Overridden_Subp));

               Parent_Unit :=
                 Enclosing_Compilation_Unit (Overridden_Subp);

               Parent_File := new String'
                 (Base_Name (To_String (Text_Name (Parent_Unit))));

               Test_Routine.TR_Parent_Unit_Decl := Parent_Unit;

               Test_Routine.TR_Rarent_Unit_Name :=
                 new String'(To_String (Unit_Full_Name (Parent_Unit)));

               Test_Routine.Test_Type_Numb := Type_Number;

               Test_Routine.Tested_Sloc := new String'
                 (Parent_File.all
                  & ":"
                  & Trim
                    (Integer'Image (First_Line_Number (Overridden_Subp)),
                     Both)
                  & ":"
                  & Trim
                    (Integer'Image (First_Column_Number (Overridden_Subp)),
                     Both)
                  & ": "
                  & Test_Routine.TR_Text_Name.all
                  & " overridden at "
                  & Base_Name (Data.Test_Unit_File_Name.all)
                  & ":"
                  & Trim
                    (Integer'Image (First_Line_Number (Original_Type)),
                     Both)
                  & ":"
                  & Trim
                    (Integer'Image (First_Column_Number (Original_Type)),
                     Both)
                  & ":");

               Data.LTR_List.Append (Test_Routine);

               Depth :=
                 Inheritance_Depth
                   (Data.Test_Types.Element (Type_Number).Test_Type,
                    Enclosing_Element (Primitive_Owner (Overridden_Subp)));

               if
                 Depth > Data.Test_Types.Element
                   (Type_Number).Max_Inheritance_Depth
               then
                  Tmp_Type_Info := Data.Test_Types.Element (Type_Number);
                  Tmp_Type_Info.Max_Inheritance_Depth := Depth;
                  Data.Test_Types.Replace_Element (Type_Number, Tmp_Type_Info);
               end if;

            end if;

         end if;

      end loop;

   end Gather_Liskiv_Data;

   ---------------------------------------------
   -- Generate_Substitution_Suite_From_Tested --
   ---------------------------------------------

   procedure Generate_Substitution_Suite_From_Tested
     (Data : Data_Holder; Path : String := "")
   is
      File_Destination : constant String :=
        (if Path = "" then Harness_Dir.all else Path);

      New_Unit_Name : constant String :=
        Data.Test_Unit_Full_Name.all & "." & Substitution_Suite_Name;

      Type_Ancestor : Asis.Element;

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

      type Duplication_Array is array
        (Data.Test_Types.First_Index .. Data.Test_Types.Last_Index) of Boolean;

      Duplication : Duplication_Array := (others => False);

      Include_Units : Include_Sets.Set;
      Include_Cur   : Include_Sets.Cursor;

      Type_Im  : String_Access;
      PUnit_Im : String_Access;
      Type_Ns  : String_Access;

      Current_TT : Test_Type_Info;
      Current_TT_Number : Natural;

      procedure Set_Current_TT (Type_Dec : Asis.Element);

      procedure Set_Current_TT (Type_Dec : Asis.Element)
      is
         Tmp_TT : Test_Type_Info;
      begin

         for
           I in Data.Test_Types.First_Index .. Data.Test_Types.Last_Index
         loop
            Tmp_TT := Data.Test_Types.Element (I);
            if Is_Equal (Tmp_TT.Tested_Type, Type_Dec) then
               Current_TT := Tmp_TT;
               Current_TT_Number := I;
               exit;
            end if;
         end loop;

      end Set_Current_TT;

   begin

      --  Creating overridden test suite spec
      Create (File_Destination
              & Unit_To_File_Name (New_Unit_Name)
              & ".ads");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      Put_New_Line;

      S_Put (0, "with AUnit.Test_Suites;");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "package " & New_Unit_Name & " is");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "use AUnit.Test_Suites;");
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "function Suite return AUnit.Test_Suites.Access_Test_Suite;");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "end " & New_Unit_Name & ";");
      Put_New_Line;
      S_Put (0, GT_Marker_End);
      Put_New_Line;

      Close_File;

      --  Gathering additional information about the tests. We need to
      --  correctly address the test types for conversion from parent
      --  tests to actual tests. Thus we should know all the names of units
      --  containing predecessor types and distinguish them.

      for I in Data.LTR_List.First_Index .. Data.LTR_List.Last_Index loop

         Set_Current_TT (Data.LTR_List.Element (I).Tested_Type);

         Type_Ancestor := Current_TT.Tested_Type;

         for
           K in 1 .. Data.Test_Types.Element
             (Current_TT_Number).Max_Inheritance_Depth
         loop

            Type_Ancestor := Parent_Type_Declaration (Type_Ancestor);

            Type_Ns  := new String'(Get_Nesting (Type_Ancestor));
            PUnit_Im := new String'(To_String (Unit_Full_Name
              (Enclosing_Compilation_Unit (Type_Ancestor))));

            if Type_Ns.all = PUnit_Im.all then
               Include_Units.Include
                 (PUnit_Im.all              &
                  "."                       &
                  Type_Name (Type_Ancestor) &
                  Test_Data_Unit_Name_Suff  &
                  "."                       &
                  Type_Name (Type_Ancestor) &
                  Test_Unit_Name_Suff);
            else
               Include_Units.Include
                 (PUnit_Im.all                                  &
                  "."                                           &
                  Test_Data_Unit_Name                           &
                  "."                                           &
                  Test_Unit_Name                                &
                  "."                                           &
                  Nesting_Difference
                    (Type_Ns.all, PUnit_Im.all)                 &
                  "."                                           &
                  Type_Name (Type_Ancestor)                     &
                  Test_Data_Unit_Name_Suff                      &
                  "."                                           &
                  Type_Name (Type_Ancestor)                     &
                  Test_Unit_Name_Suff);
            end if;

         end loop;
      end loop;

      --  Creating overridden test suite body
      Create (File_Destination
              & Unit_To_File_Name (New_Unit_Name)
              & ".adb");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      Put_New_Line;

      S_Put (0, "with AUnit.Test_Caller;");
      Put_New_Line;
      S_Put (0, "with Ada.Unchecked_Conversion;");
      Put_New_Line;
      S_Put (0, "with Gnattest_Generated;");
      Put_New_Line;
      Put_New_Line;

      --  Adding dependancy units;
      Include_Cur := Include_Units.First;
      loop
         exit when Include_Cur = Include_Sets.No_Element;
         S_Put (0, "with " & Include_Sets.Element (Include_Cur) & ";");
         Put_New_Line;
         Include_Sets.Next (Include_Cur);
      end loop;

      Put_New_Line;
      S_Put (0,
             "package body " &
             New_Unit_Name   &
             " is");
      Put_New_Line;
      Put_New_Line;

      for I in Data.Test_Types.First_Index .. Data.Test_Types.Last_Index loop
         S_Put
           (3,
            "package Runner_"  &
            Positive_Image (I) &
            " is new AUnit.Test_Caller");
         Put_New_Line;

         S_Put (5,
                "(GNATtest_Generated.GNATtest_Standard."       &
                Data.Test_Unit_Full_Name.all                   &
                "."                                            &
                Data.Test_Types.Element (I).Test_Type_Name.all &
                ");");

         Put_New_Line;
      end loop;

      Put_New_Line;

      --  Declaring access to test routines types
      for L in Data.LTR_List.First_Index .. Data.LTR_List.Last_Index loop

         Set_Current_TT (Data.LTR_List.Element (L).Tested_Type);

         Type_Ancestor := Current_TT.Tested_Type;

         if not Duplication (Current_TT_Number) then

            for K in 1 .. Current_TT.Max_Inheritance_Depth loop

               Type_Ancestor := Parent_Type_Declaration (Type_Ancestor);
               Type_Im  := new String'
                 (Test_Routine_Prefix &
                  Type_Name (Type_Ancestor));
               PUnit_Im := new String'(Type_Test_Package (Type_Ancestor));

               S_Put (3,
                      "type Test_Method_"                &
                      Positive_Image (Current_TT_Number) &
                      "_"                                &
                      Trim (Integer'Image (K), Both)     &
                      " is access procedure");
               Put_New_Line;
               S_Put (5,
                      "(T : in out " &
                      PUnit_Im.all   &
                      "."            &
                      Type_Im.all    &
                      ");");
               Put_New_Line;

               Free (Type_Im);
               Free (PUnit_Im);
            end loop;
            Duplication (Current_TT_Number) := True;
         end if;
      end loop;

      Put_New_Line;
      S_Put (3, "Result : aliased AUnit.Test_Suites.Test_Suite;");
      Put_New_Line;
      Put_New_Line;

      --  Declaring test cases
      for K in Data.LTR_List.First_Index .. Data.LTR_List.Last_Index loop

         Set_Current_TT (Data.LTR_List.Element (K).Tested_Type);

         for Depth in 1 .. Data.LTR_List.Element (K).Inheritance_Depth loop
            S_Put
              (3,
               Test_Case_Prefix                           &
               Positive_Image (Current_TT_Number)         &
               "_"                                        &
               Data.LTR_List.Element (K).TR_Text_Name.all &
               "_"                                        &
               Trim (Integer'Image (Depth), Both)         &
               " : aliased Runner_"                       &
               Positive_Image (Current_TT_Number)         &
               ".Test_Case;");
            Put_New_Line;
         end loop;

      end loop;

      Put_New_Line;
      S_Put (3,
             "function Suite return AUnit.Test_Suites.Access_Test_Suite is");
      Put_New_Line;
      Put_New_Line;

      --  Instantinating test type converters
      for K in Data.Test_Types.First_Index .. Data.Test_Types.Last_Index loop

         for
           I in 1 .. Data.Test_Types.Element (K).Max_Inheritance_Depth
         loop

            S_Put
              (6,
               "function Convert is new Gnattest_Generated." &
               "Gnattest_Standard.Ada.Unchecked_Conversion");
            Put_New_Line;
            S_Put (8,
                   "(Test_Method_"                &
                   Positive_Image (K)             &
                   "_"                            &
                   Trim (Integer'Image (I), Both) &
                   ", Runner_"                    &
                   Positive_Image (K)             &
                   ".Test_Method);");
            Put_New_Line;
         end loop;
      end loop;

      Put_New_Line;
      S_Put (3, "begin");
      Put_New_Line;
      Put_New_Line;

      --  Creating test cases
      for K in Data.LTR_List.First_Index .. Data.LTR_List.Last_Index loop

         Set_Current_TT (Data.LTR_List.Element (K).Tested_Type);

         Type_Ancestor := Current_TT.Tested_Type;

         for Depth in 1 .. Data.LTR_List.Element (K).Inheritance_Depth loop

            Type_Ancestor := Parent_Type_Declaration (Type_Ancestor);
            PUnit_Im := new String'(Type_Test_Package (Type_Ancestor));

            S_Put
              (6,
               "Runner_"                          &
               Positive_Image (Current_TT_Number) &
               ".Create");
            Put_New_Line;
            S_Put
              (8,
               "("                                        &
               Test_Case_Prefix                           &
               Positive_Image (Current_TT_Number)         &
               "_"                                        &
               Data.LTR_List.Element (K).TR_Text_Name.all &
               "_"                                        &
               Trim (Integer'Image (Depth), Both)         &
               ",");
            Put_New_Line;
            S_Put (9,
                   """"
                   & Data.LTR_List.Element (K).Tested_Sloc.all
                   & """,");
            Put_New_Line;
            S_Put (9,
                   "Convert ("                                &
                   PUnit_Im.all                               &
                   "."                                        &
                   Data.LTR_List.Element (K).TR_Text_Name.all &
                   "'Access));");
            Put_New_Line;

            Free (PUnit_Im);

         end loop;

      end loop;

      Put_New_Line;

      --  Adding test cases to the suite
      for K in Data.LTR_List.First_Index .. Data.LTR_List.Last_Index loop

         Set_Current_TT (Data.LTR_List.Element (K).Tested_Type);

         for Depth in 1 .. Data.LTR_List.Element (K).Inheritance_Depth loop
            S_Put
              (6,
               "Add_Test (Result'Access, "                      &
               Test_Case_Prefix                                 &
               Positive_Image (Current_TT_Number)               &
               "_"                                              &
               Data.LTR_List.Element (K).TR_Text_Name.all       &
               "_"                                              &
               Trim (Integer'Image (Depth), Both)               &
               "'Access);");
            Put_New_Line;

         end loop;

      end loop;

      Put_New_Line;
      S_Put (6, "return Result'Access;");
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "end Suite;");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "end " & New_Unit_Name & ";");
      Put_New_Line;
      S_Put (0, GT_Marker_End);
      Put_New_Line;
      Close_File;

      List_Of_Strings.Append (Suit_List, New_Unit_Name);

   end Generate_Substitution_Suite_From_Tested;

   ----------------------------------------------
   --  Generate_Substitution_Suite_From_Tests  --
   ----------------------------------------------

   procedure Generate_Substitution_Suite_From_Tests (Data : Data_Holder) is

      New_Unit_Name : constant String :=
        Data.Test_Unit_Full_Name.all & "." & Substitution_Suite_Name;

      Type_Im  : String_Access;
      PUnit_Im : String_Access;

      Type_Ancestor : Asis.Element;

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

      Include_Units : Include_Sets.Set;
      Include_Cur   : Include_Sets.Cursor;

      Type_Number : Positive;
   begin

      --  Creating overridden test suite spec
      Create (Harness_Dir.all                    &
              Unit_To_File_Name (New_Unit_Name) &
              ".ads");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      Put_New_Line;

      S_Put (0, "with AUnit.Test_Suites;");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "package " & New_Unit_Name & " is");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "use AUnit.Test_Suites;");
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "function Suite return AUnit.Test_Suites.Access_Test_Suite;");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "end " & New_Unit_Name & ";");
      Put_New_Line;
      S_Put (0, GT_Marker_End);
      Put_New_Line;

      Close_File;

      --  Gathering additional information about the tests. We need to
      --  correctly address the test types for conversion from parent
      --  tests to actual tests. Thus we should know all the names of units
      --  containing predecessor types and distinguish them.

      for I in Data.Test_Types.First_Index .. Data.Test_Types.Last_Index loop
         Type_Ancestor := Data.Test_Types.Element (I).Test_Type;
         for K in 1 .. Data.Test_Types.Element (I).Max_Inheritance_Depth loop
            Type_Ancestor := Parent_Type_Declaration (Type_Ancestor);
            PUnit_Im := new String'(To_String (Unit_Full_Name
              (Enclosing_Compilation_Unit (Type_Ancestor))));
            Include_Units.Include (PUnit_Im.all);
            Free (PUnit_Im);
         end loop;
      end loop;

      --  Creating overridden test suite body
      Create (Harness_Dir.all                    &
              Unit_To_File_Name (New_Unit_Name) &
              ".adb");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      Put_New_Line;

      S_Put (0, "with AUnit.Test_Caller;");
      Put_New_Line;
      S_Put (0, "with Ada.Unchecked_Conversion;");
      Put_New_Line;
      S_Put (0, "with Gnattest_Generated;");
      Put_New_Line;
      Put_New_Line;

      --  Adding dependancy units;
      Include_Cur := Include_Units.First;
      loop
         exit when Include_Cur = Include_Sets.No_Element;
         S_Put (0, "with " & Include_Sets.Element (Include_Cur) & ";");
         Put_New_Line;
         Include_Sets.Next (Include_Cur);
      end loop;

      Put_New_Line;
      S_Put (0,
             "package body " &
             New_Unit_Name   &
             " is");
      Put_New_Line;
      Put_New_Line;

      for I in Data.Test_Types.First_Index .. Data.Test_Types.Last_Index loop
         S_Put
           (3,
            "package Runner_"  &
            Positive_Image (I) &
            " is new AUnit.Test_Caller");
         Put_New_Line;

         S_Put (5,
                "(GNATtest_Generated.GNATtest_Standard."       &
                Data.Test_Unit_Full_Name.all                   &
                "."                                            &
                Data.Test_Types.Element (I).Test_Type_Name.all &
                ");");

         Put_New_Line;
      end loop;

      Put_New_Line;

      --  Declaring access to test routines types
      for I in Data.Test_Types.First_Index .. Data.Test_Types.Last_Index loop

         Type_Ancestor := Data.Test_Types.Element (I).Test_Type;

         for K in 1 .. Data.Test_Types.Element (I).Max_Inheritance_Depth loop

            Type_Ancestor := Parent_Type_Declaration (Type_Ancestor);
            Type_Im  := new String'(To_String (Defining_Name_Image (First_Name
              (Type_Ancestor))));
            PUnit_Im := new String'(To_String (Unit_Full_Name
              (Enclosing_Compilation_Unit (Type_Ancestor))));

            S_Put (3,
                   "type Test_Method_"            &
                   Positive_Image (I)             &
                   "_"                            &
                   Trim (Integer'Image (K), Both) &
                   " is access procedure");
            Put_New_Line;
            S_Put (5,
                   "(T : in out " &
                   PUnit_Im.all   &
                   "."            &
                   Type_Im.all    &
                   ");");
            Put_New_Line;

            Free (Type_Im);
            Free (PUnit_Im);
         end loop;
      end loop;

      Put_New_Line;
      S_Put (3, "Result : aliased AUnit.Test_Suites.Test_Suite;");
      Put_New_Line;
      Put_New_Line;

      --  Declaring test cases
      for K in Data.LTR_List.First_Index .. Data.LTR_List.Last_Index loop

         Type_Number := Data.LTR_List.Element (K).Test_Type_Numb;

         for Depth in 1 .. Inheritance_Depth
           (Data.Test_Types.Element (Type_Number).Test_Type,
            Enclosing_Element (Primitive_Owner
              (Data.LTR_List.Element (K).TR_Declaration)))
         loop
            S_Put
              (3,
               Test_Case_Prefix                           &
               Positive_Image (Type_Number)               &
               "_"                                        &
               Data.LTR_List.Element (K).TR_Text_Name.all &
               "_"                                        &
               Trim (Integer'Image (Depth), Both)         &
               " : aliased Runner_"                       &
               Positive_Image (Type_Number)               &
               ".Test_Case;");
            Put_New_Line;
         end loop;

      end loop;

      Put_New_Line;
      S_Put (3,
             "function Suite return AUnit.Test_Suites.Access_Test_Suite is");
      Put_New_Line;
      Put_New_Line;

      --  Instantinating test type converters
      for K in Data.Test_Types.First_Index .. Data.Test_Types.Last_Index loop

         for
           I in 1 .. Data.Test_Types.Element (K).Max_Inheritance_Depth
         loop

            S_Put
              (6,
               "function Convert is new Gnattest_Generated." &
               "Gnattest_Standard.Ada.Unchecked_Conversion");
            Put_New_Line;
            S_Put (8,
                   "(Test_Method_"                &
                   Positive_Image (K)             &
                   "_"                            &
                   Trim (Integer'Image (I), Both) &
                   ", Runner_"                    &
                   Positive_Image (K)             &
                   ".Test_Method);");
            Put_New_Line;
         end loop;
      end loop;

      Put_New_Line;
      S_Put (3, "begin");
      Put_New_Line;
      Put_New_Line;

      --  Creating test cases
      for K in Data.LTR_List.First_Index .. Data.LTR_List.Last_Index loop

         Type_Number := Data.LTR_List.Element (K).Test_Type_Numb;
         Type_Ancestor := Data.Test_Types.Element (Type_Number).Test_Type;

         for Depth in 1 .. Inheritance_Depth
           (Data.Test_Types.Element (Type_Number).Test_Type,
            Enclosing_Element (Primitive_Owner
              (Data.LTR_List.Element (K).TR_Declaration)))
         loop

            Type_Ancestor := Parent_Type_Declaration (Type_Ancestor);
            PUnit_Im := new String'(To_String (Unit_Full_Name
              (Enclosing_Compilation_Unit (Type_Ancestor))));

            S_Put
              (6,
               "Runner_"                    &
               Positive_Image (Type_Number) &
               ".Create");
            Put_New_Line;
            S_Put
              (8,
               "("                                        &
               Test_Case_Prefix                           &
               Positive_Image (Type_Number)               &
               "_"                                        &
               Data.LTR_List.Element (K).TR_Text_Name.all &
               "_"                                        &
               Trim (Integer'Image (Depth), Both)         &
               ",");
            Put_New_Line;
            S_Put (9,
                   """"
                   & Data.LTR_List.Element (K).Tested_Sloc.all
                   & """,");
            Put_New_Line;
            S_Put (9,
                   "Convert ("                                &
                   PUnit_Im.all                               &
                   "."                                        &
                   Data.LTR_List.Element (K).TR_Text_Name.all &
                   "'Access));");
            Put_New_Line;

            Free (PUnit_Im);

         end loop;

      end loop;

      Put_New_Line;

      --  Adding test cases to the suite
      for K in Data.LTR_List.First_Index .. Data.LTR_List.Last_Index loop

         Type_Number := Data.LTR_List.Element (K).Test_Type_Numb;

         for Depth in 1 .. Inheritance_Depth
           (Data.Test_Types.Element (Type_Number).Test_Type,
            Enclosing_Element (Primitive_Owner
              (Data.LTR_List.Element (K).TR_Declaration)))
         loop

            S_Put
              (6,
               "Add_Test (Result'Access, "                &
               Test_Case_Prefix                           &
               Positive_Image (Type_Number)               &
               "_"                                        &
               Data.LTR_List.Element (K).TR_Text_Name.all &
               "_"                                        &
               Trim (Integer'Image (Depth), Both)         &
               "'Access);");
            Put_New_Line;

         end loop;

      end loop;

      Put_New_Line;
      S_Put (6, "return Result'Access;");
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "end Suite;");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "end " & New_Unit_Name & ";");
      Put_New_Line;
      S_Put (0, GT_Marker_End);
      Put_New_Line;

      Close_File;

      List_Of_Strings.Append (Suit_List, New_Unit_Name);

   end Generate_Substitution_Suite_From_Tests;

   ---------------------------
   -- Generate_Test_Drivers --
   ---------------------------

   procedure Generate_Test_Drivers
     (Data      : Data_Holder;
      UUT       : String;
      Stub_List : Asis_Element_List.List)
   is

      procedure Process_Test_Routine (Current_TR : Test_Routine_Info'Class);
      procedure Process_Test_Package;

      function Recover_Test_Data_Unit_Name (S : String) return String;

      function Get_SPI
        (Current_TR    : Test_Routine_Info'Class;
         New_Unit_Dir  : String_Access;
         New_Unit_Name : String_Access)
         return Separate_Project_Info;

      Local_SPI         : Separate_Project_Info;
      Local_Data_Holder : Data_Holder := Data;

      function Get_SPI
        (Current_TR    : Test_Routine_Info'Class;
         New_Unit_Dir  : String_Access;
         New_Unit_Name : String_Access)
         return Separate_Project_Info
      is
         SPI : Separate_Project_Info;
      begin
         Trace (Me, "getting separate project info...");
         SPI.Name_TD         := new String'
           (TD_Prefix
            & Current_TR.TR_Text_Name.all);
         SPI.Path_TD         := new String'
           (New_Unit_Dir.all
            & Unit_To_File_Name
              (TD_Prefix
               & Current_TR.TR_Text_Name.all)
            & ".gpr");
         SPI.Main_File_Name   := new String'
           (Unit_To_File_Name (New_Unit_Name.all)
            & ".adb");

         if not Stub_Mode_ON then
            Trace (Me, "done");
            return SPI;
         end if;

         SPI.UUT_File_Name := new String'
           (GNATtest.Skeleton.Source_Table.Get_Current_Source_Spec);

         declare
            Corresponding_Body : constant String :=
              GNATtest.Skeleton.Source_Table.Get_Source_Body (UUT);
            Project_Name : constant String :=
              (if Corresponding_Body = "" then
                  GNATtest.Skeleton.Source_Table.Get_Source_Project_Name (UUT)
               else
                  GNATtest.Skeleton.Source_Table.Get_Source_Project_Name
                    (Corresponding_Body));
            Project_Path : constant String :=
              GNATtest.Skeleton.Source_Table.Get_Project_Path (Project_Name);

            Cur : Asis_Element_List.Cursor;
         begin
            SPI.Name_Extending := new String'
              (Current_TR.TR_Text_Name.all);
            SPI.Path_Extending := new String'
              (New_Unit_Dir.all
               & Unit_To_File_Name
                 (Current_TR.TR_Text_Name.all)
               & ".gpr");

            SPI.Name_Of_Extended := new String'
              (Project_Name);
            SPI.Path_Of_Extended := new String'
              (+Relative_Path
                 (Create (+Project_Path),
                  Create (+New_Unit_Dir.all)));

            SPI.Test_Package := new String'
              (Data.Test_Unit_Full_Name.all);
            SPI.Test_Data    := new String'
              (Recover_Test_Data_Unit_Name
                 (Data.Test_Unit_Full_Name.all));

            Cur := Stub_List.First;
            while Cur /= Asis_Element_List.No_Element loop
               declare
                  S : constant String :=
                    To_String
                      (Text_Name
                         (Enclosing_Compilation_Unit
                            (Asis_Element_List.Element (Cur))));
               begin
                  --  If any source meant to be stubbed is from same
                  --  project and is actually stubbed, then stub dir should
                  --  be set.
                  if
                    Project_Path =
                      GNATtest.Skeleton.Source_Table.Get_Project_Path
                        (GNATtest.Skeleton.Source_Table.
                           Get_Source_Project_Name (S)) and then
                        GNATtest.Skeleton.Source_Table.Source_Stubbed (S)
                  then

                     if S /= UUT then
                        declare
                           App : constant String :=
                             GNATtest.Skeleton.Source_Table.Get_Source_Body
                               (S);
                        begin
                           if App /= "" then
                              SPI.Sources_List.Append (App);
                              declare
                                 SD_Spec : constant String :=
                                   GNATtest.Skeleton.Source_Table.
                                     Get_Source_Stub_Data_Spec (S);
                                 SD_Body : constant String :=
                                   GNATtest.Skeleton.Source_Table.
                                     Get_Source_Stub_Data_Body (S);
                              begin
                                 if not
                                   Excluded_Test_Data_Files.Contains (SD_Spec)
                                 then
                                    SPI.Sources_List.Append (SD_Spec);
                                 end if;
                                 if not
                                   Excluded_Test_Data_Files.Contains (SD_Body)
                                 then
                                    SPI.Sources_List.Append (SD_Body);
                                 end if;
                              end;
                           end if;
                        end;
                     end if;

                     if SPI.Stub_Source_Dir = null then
                        SPI.Stub_Source_Dir := new String'
                          (GNATtest.Skeleton.Source_Table.
                             Get_Project_Stub_Dir (Project_Name));
                     end if;
                  end if;
               end;

               Next (Cur);
            end loop;
         end;

         Trace (Me, "done");
         return SPI;
      end Get_SPI;

      function Recover_Test_Data_Unit_Name (S : String) return String is
      begin
         for I in reverse S'Range loop
            if S (I) = '.' then
               return S (S'First .. I - 1);
            end if;
         end loop;

         return S;
      end Recover_Test_Data_Unit_Name;

      procedure Process_Test_Package is
         New_Unit_Dir : constant String :=
           Harness_Dir.all
           & Data.Test_Unit_Full_Name.all
           & Directory_Separator;

         New_Unit_Name : constant String :=
           (Data.Test_Unit_Full_Name.all
            & ".Suite.Test_Runner");
      begin
         Trace (Me, "processing package " & Data.Test_Unit_Full_Name.all);

         declare
            Dir : File_Array_Access;
         begin
            Append (Dir, GNATCOLL.VFS.Create (+New_Unit_Dir));
            Create_Dirs (Dir);
         exception
            when Directory_Error =>
               Report_Err
                 ("gnattest: cannot create directory " & New_Unit_Dir);
               raise Fatal_Error;
         end;

         --  Creating test driver procedure
         Create (New_Unit_Dir
                 & Unit_To_File_Name (New_Unit_Name)
                 & ".adb");

         Put_Harness_Header;
         S_Put (0, GT_Marker_Begin);
         Put_New_Line;

         S_Put (0, "with AUnit.Test_Suites; use AUnit.Test_Suites;");
         Put_New_Line;
         if not Stub_Mode_ON then
            S_Put (0, "with AUnit.Test_Caller;");
            Put_New_Line;
         end if;
         S_Put (0, "with Gnattest_Generated;");
         Put_New_Line;
         S_Put (0, "with AUnit.Reporter.GNATtest;");
         Put_New_Line;
         S_Put (0, "with AUnit.Run;");
         Put_New_Line;
         S_Put (0, "with AUnit.Options; use AUnit.Options;");
         Put_New_Line;
         if Data.Good_For_Substitution then
            S_Put
              (0,
               "with "
               & Data.Test_Unit_Full_Name.all
               & "."
               & Substitution_Suite_Name
               & "; use "
               & Data.Test_Unit_Full_Name.all
               & "."
               & Substitution_Suite_Name
               & ";");
            Put_New_Line;
         end if;

         S_Put (0, "procedure " & New_Unit_Name & " is");
         Put_New_Line;
         Put_New_Line;

         if Data.Good_For_Substitution then
            S_Put
              (3,
               "function Suite return AUnit.Test_Suites.Access_Test_Suite;");
            Put_New_Line;
            Put_New_Line;
            S_Put (3, "Result : aliased AUnit.Test_Suites.Test_Suite;");
            Put_New_Line;
            Put_New_Line;
            S_Put
              (3,
               "function Suite return AUnit.Test_Suites.Access_Test_Suite is");
            Put_New_Line;
            S_Put (3, "begin");
            Put_New_Line;
            Put_New_Line;
            S_Put
              (6,
               "Add_Test (Result'Access, "
               & Data.Test_Unit_Full_Name.all
               & "."
               & Common_Suite_Name
               & ".Suite);");
            Put_New_Line;
            S_Put
              (6,
               "Add_Test (Result'Access, "
               & Data.Test_Unit_Full_Name.all
               & "."
               & Substitution_Suite_Name
               & ".Suite);");
            Put_New_Line;
            Put_New_Line;
            S_Put (6, "return Result'Unchecked_Access;");
            Put_New_Line;
            Put_New_Line;
            S_Put (3, "end Suite;");
            Put_New_Line;
            Put_New_Line;

         end if;

         S_Put (3, "procedure Runner is new AUnit.Run.Test_Runner (Suite);");
         Put_New_Line;
         S_Put (3, "Reporter : AUnit.Reporter.GNATtest.GNATtest_Reporter;");
         Put_New_Line;
         S_Put (3, "GT_Options : AUnit_Options := Default_Options;");
         Put_New_Line;
         Put_New_Line;

         S_Put (0, "begin");
         Put_New_Line;
         if Show_Passed_Tests then
            S_Put (3, "GT_Options.Report_Successes := True;");
         else
            S_Put (3, "GT_Options.Report_Successes := False;");
         end if;
         Put_New_Line;
         if Show_Test_Duration then
            S_Put (3,
                   "GT_Options.Test_Case_Timer := True;");
            Put_New_Line;
         end if;
         Put_New_Line;
         S_Put (3, "Runner (Reporter, GT_Options);");
         Put_New_Line;

         S_Put (0, "end " & New_Unit_Name & ";");
         Put_New_Line;
         S_Put (0, GT_Marker_End);
         Put_New_Line;
         Close_File;

      end Process_Test_Package;

      procedure Process_Test_Routine (Current_TR : Test_Routine_Info'Class)
      is
         Current_Type : constant Test_Type_Info :=
          Data.Test_Types.Element (Current_TR.Test_Type_Numb);

         New_Unit_Name : String_Access;
         New_Unit_Dir  : String_Access;
      begin
         Trace (Me, "processing routine " & Current_TR.TR_Text_Name.all);

         New_Unit_Name := new String'
           (Data.Test_Unit_Full_Name.all
            & "."
            & TD_Prefix
            & Current_TR.TR_Text_Name.all);

         --  Distinguish different set of test drivers by putting them in dirs
         --  with names corresponding to UUTs.
         New_Unit_Dir := new String'
           (Harness_Dir.all
            & Data.Test_Unit_Full_Name.all
            & Directory_Separator);

         declare
            Dir : File_Array_Access;
         begin
            Append (Dir, GNATCOLL.VFS.Create (+New_Unit_Dir.all));
            Create_Dirs (Dir);
         exception
            when Directory_Error =>
               Report_Err
                 ("gnattest: cannot create directory " & New_Unit_Dir.all);
               raise Fatal_Error;
         end;

         --  Creating test driver procedure
         Create (New_Unit_Dir.all
                 & Unit_To_File_Name (New_Unit_Name.all)
                 & ".adb");

         Put_Harness_Header;
         S_Put (0, GT_Marker_Begin);
         Put_New_Line;

         S_Put (0, "pragma Ada_2005;");
         Put_New_Line;
         Put_New_Line;
         S_Put (0, "with AUnit.Test_Suites; use AUnit.Test_Suites;");
         Put_New_Line;
         if not Stub_Mode_ON then
            S_Put (0, "with AUnit.Test_Caller;");
            Put_New_Line;
         end if;
         S_Put (0, "with Gnattest_Generated;");
         Put_New_Line;
         S_Put (0, "with AUnit.Reporter.GNATtest;");
         Put_New_Line;
         S_Put (0, "with AUnit.Run;");
         Put_New_Line;
         S_Put (0, "with AUnit.Options; use AUnit.Options;");
         Put_New_Line;
         Put_New_Line;

         S_Put (0, "procedure " & New_Unit_Name.all & " is");
         Put_New_Line;
         Put_New_Line;

         S_Put
           (3, "function Suite return AUnit.Test_Suites.Access_Test_Suite;");
         Put_New_Line;
         Put_New_Line;

         S_Put (3, "Result : aliased AUnit.Test_Suites.Test_Suite;");
         Put_New_Line;
         if not Stub_Mode_ON then
            S_Put
              (3,
               "package Caller is new AUnit.Test_Caller");
            Put_New_Line;
            S_Put
              (5,
               "(GNATtest_Generated.GNATtest_Standard."
               & Data.Test_Unit_Full_Name.all
               & "."
               & Current_Type.Test_Type_Name.all
               & ");");
            Put_New_Line;
         end if;
         S_Put (3, "Local_Test_Case : aliased Caller.Test_Case;");
         Put_New_Line;
         Put_New_Line;

         S_Put
           (3, "function Suite return AUnit.Test_Suites.Access_Test_Suite is");
         Put_New_Line;
         S_Put (3, "begin");
         Put_New_Line;
         S_Put (6, "Caller.Create");
         Put_New_Line;
         S_Put (8, "(Local_Test_Case,");
         Put_New_Line;
         S_Put (9,
                """"
                & Current_TR.Tested_Sloc.all
                & """,");
         Put_New_Line;
         S_Put (9,
                Current_TR.TR_Text_Name.all
                & "'Access);");
         Put_New_Line;
         Put_New_Line;
         S_Put (6, "Add_Test (Result'Access, Local_Test_Case'Access);");
         Put_New_Line;
         Put_New_Line;
         S_Put (6, "return Result'Unchecked_Access;");
         Put_New_Line;
         S_Put (3, "end Suite;");
         Put_New_Line;
         Put_New_Line;

         S_Put (3, "procedure Runner is new AUnit.Run.Test_Runner (Suite);");
         Put_New_Line;
         S_Put (3, "Reporter : AUnit.Reporter.GNATtest.GNATtest_Reporter;");
         Put_New_Line;
         S_Put (3, "GT_Options : AUnit_Options := Default_Options;");
         Put_New_Line;
         Put_New_Line;

         S_Put (0, "begin");
         Put_New_Line;
         if Show_Passed_Tests then
            S_Put (3, "GT_Options.Report_Successes := True;");
         else
            S_Put (3, "GT_Options.Report_Successes := False;");
         end if;
         Put_New_Line;
         if Show_Test_Duration then
            S_Put (3,
                   "GT_Options.Test_Case_Timer := True;");
            Put_New_Line;
         end if;
         Put_New_Line;
         S_Put (3, "Runner (Reporter, GT_Options);");
         Put_New_Line;

         S_Put (0, "end " & New_Unit_Name.all & ";");
         Put_New_Line;
         S_Put (0, GT_Marker_End);
         Put_New_Line;
         Close_File;

         Separate_Projects.Append
           (Get_SPI
              (Current_TR,
               New_Unit_Dir,
               New_Unit_Name));

      end Process_Test_Routine;
   begin
      Trace (Me, "Generate_Test_Drivers");
      Increase_Indent (Me);

      if Driver_Per_Unit then
         Process_Test_Package;
         if Stub_Mode_ON then
            --  No test inheritance in stub mode. We need to clear the list
            --  of inherited test routines, otherwise corresponding test cases
            --  will be declared in the suite.
            Local_Data_Holder.ITR_List.Clear;
         end if;
         Generate_Suite
           (Local_Data_Holder,
            Harness_Dir.all
            & Data.Test_Unit_Full_Name.all
            & Directory_Separator);
         if not Stub_Mode_ON and then Data.Good_For_Substitution then
            Generate_Substitution_Suite_From_Tested
              (Local_Data_Holder,
               Harness_Dir.all
               & Data.Test_Unit_Full_Name.all
               & Directory_Separator);
         end if;

         declare
            S1 : constant String_Access := new String'
              (Harness_Dir.all
               & Data.Test_Unit_Full_Name.all
               & Directory_Separator);
            S2 : constant String_Access := new String'
              (Data.Test_Unit_Full_Name.all
               & ".Suite.Test_Runner");
         begin
            --  We may reuse the regular way of gathering data for separate
            --  drivers. Just need to override the names and paths for
            --  the generated projects.

            if Data.TR_List.Is_Empty then
               if Stub_Mode_ON then
                  --  No test inheritance in stub mode.
                  return;
               end if;
               Local_SPI := Get_SPI (Data.ITR_List.First_Element, S1, S2);
            else
               Local_SPI := Get_SPI (Data.TR_List.First_Element, S1, S2);
            end if;

            Free (Local_SPI.Name_TD);
            Local_SPI.Name_TD := new String'("Test_Driver");
            Free (Local_SPI.Name_Extending);
            Local_SPI.Name_Extending := new String'("Stubs");
            Free (Local_SPI.Path_TD);
            Local_SPI.Path_TD := new String'(S1.all & "test_driver.gpr");
            Free (Local_SPI.Path_Extending);
            Local_SPI.Path_Extending := new String'(S1.all & "stubs.gpr");
         end;

         Separate_Projects.Append (Local_SPI);
         Decrease_Indent (Me, "done");
         return;
      end if;

      for K in Data.TR_List.First_Index .. Data.TR_List.Last_Index loop
         Process_Test_Routine (Data.TR_List.Element (K));
      end loop;

      if Separate_Drivers and then not Stub_Mode_ON then
         for K in Data.ITR_List.First_Index .. Data.ITR_List.Last_Index loop
            Process_Test_Routine (Data.ITR_List.Element (K));
         end loop;
      end if;

      Decrease_Indent (Me, "done");
   end Generate_Test_Drivers;

   ----------------------------------------
   -- Generate_Substitution_Test_Drivers --
   ----------------------------------------

   procedure Generate_Substitution_Test_Drivers (Data : Data_Holder) is
      Current_Type : Test_Type_Info;
      Type_Ancestor : Asis.Element;

      Current_TR : Test_Routine_Info_Enhanced;

      New_Unit_Name : String_Access;
      New_Unit_Dir  : String_Access;

      function Get_SPI
        (Current_TR    : Test_Routine_Info'Class;
         New_Unit_Dir  : String_Access;
         New_Unit_Name : String_Access)
         return Separate_Project_Info;

      function Get_SPI
        (Current_TR    : Test_Routine_Info'Class;
         New_Unit_Dir  : String_Access;
         New_Unit_Name : String_Access)
         return Separate_Project_Info
      is
         SPI : Separate_Project_Info;
      begin
         SPI.Name_TD         := new String'
           (TD_Prefix_Overriden
            & Current_TR.TR_Text_Name.all);
         SPI.Path_TD         := new String'
           (New_Unit_Dir.all
            & Unit_To_File_Name
              (TD_Prefix_Overriden
               & Current_TR.TR_Text_Name.all)
            & ".gpr");
         SPI.Main_File_Name   := new String'
           (Unit_To_File_Name (New_Unit_Name.all)
            & ".adb");

         return SPI;
      end Get_SPI;

   begin

      for K in Data.LTR_List.First_Index .. Data.LTR_List.Last_Index loop

         Current_TR   := Data.LTR_List.Element (K);
         Current_Type := Data.Test_Types.Element (Current_TR.Test_Type_Numb);

         New_Unit_Name := new String'
           (Data.Test_Unit_Full_Name.all
            & "."
            & TD_Prefix_Overriden
            & Current_TR.TR_Text_Name.all);

         --  Distinguish different set of test drivers by putting them in dirs
         --  with names corresponding to UUTs.
         New_Unit_Dir := new String'
           (Harness_Dir.all
            & Data.Test_Unit_Full_Name.all
            & Directory_Separator);

         declare
            Dir : File_Array_Access;
         begin
            Append (Dir, GNATCOLL.VFS.Create (+New_Unit_Dir.all));
            Create_Dirs (Dir);
         exception
            when Directory_Error =>
               Report_Err
                 ("gnattest: cannot create directory " & New_Unit_Dir.all);
               raise Fatal_Error;
         end;

         --  Creating test driver procedure
         Create (New_Unit_Dir.all
                 & Unit_To_File_Name (New_Unit_Name.all)
                 & ".adb");

         Put_Harness_Header;
         S_Put (0, GT_Marker_Begin);
         Put_New_Line;

         S_Put (0, "pragma Ada_2005;");
         Put_New_Line;
         Put_New_Line;
         S_Put (0, "with AUnit.Test_Suites; use AUnit.Test_Suites;");
         Put_New_Line;
         S_Put (0, "with AUnit.Test_Caller;");
         Put_New_Line;
         S_Put (0, "with Gnattest_Generated;");
         Put_New_Line;
         S_Put (0, "with AUnit.Reporter.GNATtest;");
         Put_New_Line;
         S_Put (0, "with AUnit.Run;");
         Put_New_Line;
         S_Put (0, "with AUnit.Options; use AUnit.Options;");
         Put_New_Line;
         S_Put (0, "with Ada.Unchecked_Conversion;");
         Put_New_Line;
         Put_New_Line;

         Type_Ancestor := Current_Type.Tested_Type;

         for I in 1 .. Current_Type.Max_Inheritance_Depth loop
            Type_Ancestor := Parent_Type_Declaration (Type_Ancestor);
            S_Put (0, "with " & Type_Test_Package (Type_Ancestor) & ";");
            Put_New_Line;
         end loop;

         Put_New_Line;

         S_Put (0, "procedure " & New_Unit_Name.all & " is");
         Put_New_Line;
         Put_New_Line;

         Type_Ancestor := Current_Type.Tested_Type;

         for I in 1 .. Current_Type.Max_Inheritance_Depth loop
            Type_Ancestor := Parent_Type_Declaration (Type_Ancestor);
            S_Put
              (3,
               "type Test_Method_"
               & Trim (Integer'Image (I), Both)
               & " is access procedure");
            Put_New_Line;
            Put_New_Line;
            S_Put
              (5,
               "(T : in out "
               & Type_Test_Package (Type_Ancestor)
               & ".Test_"
               & Type_Name (Type_Ancestor)
               & ");");
            Put_New_Line;
         end loop;

         S_Put
           (3, "function Suite return AUnit.Test_Suites.Access_Test_Suite;");
         Put_New_Line;
         Put_New_Line;

         S_Put (3, "Result : aliased AUnit.Test_Suites.Test_Suite;");
         Put_New_Line;
         S_Put
           (3,
            "package Caller is new AUnit.Test_Caller");
         Put_New_Line;
         S_Put
           (5,
            "(GNATtest_Generated.GNATtest_Standard."
            & Data.Test_Unit_Full_Name.all
            & "."
            & Current_Type.Test_Type_Name.all
            & ");");
         Put_New_Line;

         for I in 1 .. Current_Type.Max_Inheritance_Depth loop
            S_Put
              (3,
               "Local_Test_Case_"
               & Trim (Integer'Image (I), Both)
               & " : aliased Caller.Test_Case;");
            Put_New_Line;
         end loop;

         Put_New_Line;

         S_Put
           (3, "function Suite return AUnit.Test_Suites.Access_Test_Suite is");
         Put_New_Line;
         Put_New_Line;

         for I in 1 .. Current_Type.Max_Inheritance_Depth loop
            S_Put
              (6,
               "function Convert is new Gnattest_Generated." &
               "Gnattest_Standard.Ada.Unchecked_Conversion");
            S_Put
              (8,
               "(Test_Method_"
               & Trim (Integer'Image (I), Both)
               & ", Caller.Test_Method);");
            Put_New_Line;
         end loop;
         Put_New_Line;

         S_Put (3, "begin");
         Put_New_Line;

         Type_Ancestor := Current_Type.Tested_Type;

         for I in 1 .. Current_Type.Max_Inheritance_Depth loop
            Type_Ancestor := Parent_Type_Declaration (Type_Ancestor);

            S_Put (6, "Caller.Create");
            Put_New_Line;
            S_Put
              (8,
               "(Local_Test_Case_"
               & Trim (Integer'Image (I), Both)
               & ",");
            Put_New_Line;
            S_Put (9,
                   """"
                   & Current_TR.Tested_Sloc.all
                   & """,");
            Put_New_Line;
            S_Put (9,
                   "Convert ("
                   & Type_Test_Package (Type_Ancestor)
                   & "."
                   & Current_TR.TR_Text_Name.all
                   & "'Access));");
            Put_New_Line;
         end loop;

         Put_New_Line;
         for I in 1 .. Current_Type.Max_Inheritance_Depth loop
            S_Put
              (6,
               "Add_Test (Result'Access, Local_Test_Case_"
               & Trim (Integer'Image (I), Both)
               & "'Access);");
            Put_New_Line;
         end loop;

         Put_New_Line;
         S_Put (6, "return Result'Unchecked_Access;");
         Put_New_Line;
         S_Put (3, "end Suite;");
         Put_New_Line;
         Put_New_Line;

         S_Put (3, "procedure Runner is new AUnit.Run.Test_Runner (Suite);");
         Put_New_Line;
         S_Put (3, "Reporter : AUnit.Reporter.GNATtest.GNATtest_Reporter;");
         Put_New_Line;
         S_Put (3, "GT_Options : AUnit_Options := Default_Options;");
         Put_New_Line;
         Put_New_Line;

         S_Put (0, "begin");
         Put_New_Line;
         if Show_Passed_Tests then
            S_Put (3, "GT_Options.Report_Successes := True;");
         else
            S_Put (3, "GT_Options.Report_Successes := False;");
         end if;
         Put_New_Line;
         if Show_Test_Duration then
            S_Put (3,
                   "GT_Options.Test_Case_Timer := True;");
            Put_New_Line;
         end if;
         Put_New_Line;
         S_Put (3, "Runner (Reporter, GT_Options);");
         Put_New_Line;

         S_Put (0, "end " & New_Unit_Name.all & ";");
         Put_New_Line;
         S_Put (0, GT_Marker_End);
         Put_New_Line;
         Close_File;

         Separate_Projects.Append
           (Get_SPI
              (Current_TR,
               New_Unit_Dir,
               New_Unit_Name));
      end loop;
   end Generate_Substitution_Test_Drivers;

   -----------------------------------
   -- Generate_Test_Driver_Projects --
   -----------------------------------

   procedure Generate_Test_Driver_Projects is
      P : Separate_Project_Info;
   begin
      if Separate_Projects.Is_Empty then
         Report_Std
           ("gnattest: no test skeletons generated because "
            & "no subprogram to test");
         Report_Std
           ("found in project " & Source_Prj.all, 10);
         Report_Std ("cannot create main suite and test runner", 10);
         raise Fatal_Error;
      end if;

      for
        K in Separate_Projects.First_Index .. Separate_Projects.Last_Index
      loop
         P := Separate_Projects.Element (K);

         declare
            Dir : File_Array_Access;
         begin
            Append
              (Dir,
               GNATCOLL.VFS.Create
                 (+(Dir_Name (P.Path_TD.all)
                  & Directory_Separator
                  & P.Name_TD.all
                  & "_obj")));
            Create_Dirs (Dir);
         exception
            when Directory_Error =>
               Report_Err
                 ("gnattest: cannot create obj directory for "
                  & P.Path_TD.all);
               raise Fatal_Error;
         end;

         Create (P.Path_TD.all);

         S_Put (0, "with ""aunit"";");
         Put_New_Line;
         S_Put
           (0,
            "with """
              & (+Relative_Path
                 (Create (+Tmp_Test_Prj.all),
                   Create (+Dir_Name (P.Path_TD.all))))
            & """;");
         Put_New_Line;
         S_Put
           (0,
            "with """
              & (+Relative_Path
                 (Create (+Gnattest_Common_Prj_Name),
                   Create (+Dir_Name (P.Path_TD.all))))
            & """;");
         Put_New_Line;
         Put_New_Line;

         S_Put
           (0,
            "project "
            & P.Name_TD.all
            & " is");
         Put_New_Line;
         Put_New_Line;
         S_Put
           (3,
            "for Origin_Project use """
            & (+Relative_Path
                 (Create (+Source_Prj.all),
                   Create (+Normalize_Pathname (Dir_Name (P.Path_TD.all)))))
            & """;");
         Put_New_Line;
         Put_New_Line;

         S_Put (3, "for Target use Gnattest_Common'Target;");
         Put_New_Line;
         Put_New_Line;
         S_Put
           (3,
            "for Runtime (""Ada"") use Gnattest_Common'Runtime (""Ada"");");
         Put_New_Line;
         Put_New_Line;

         S_Put (3, "package Ide renames Gnattest_Common.Ide;");
         Put_New_Line;
         Put_New_Line;
         S_Put (3, "package Make renames Gnattest_Common.Make;");
         Put_New_Line;
         Put_New_Line;

         S_Put (3, "for Languages use Gnattest_Common'Languages & (""Ada"");");
         Put_New_Line;

         S_Put
           (3,
            "for Main use ("""
            & P.Main_File_Name.all
            & """);");
         Put_New_Line;
         S_Put (3, "for Exec_Dir use ""."";");
         Put_New_Line;
         S_Put (3, "for Source_Dirs use (""."");");
         Put_New_Line;
         S_Put
           (3,
            "for Object_Dir use """
            & P.Name_TD.all
            & "_obj"";");
         Put_New_Line;
         Put_New_Line;

         S_Put (3, "package Builder renames Gnattest_Common.Builder;");
         Put_New_Line;
         S_Put (3, "package Linker renames Gnattest_Common.Linker;");
         Put_New_Line;
         S_Put (3, "package Binder renames Gnattest_Common.Binder;");
         Put_New_Line;
         S_Put (3, "package Compiler renames Gnattest_Common.Compiler;");
         Put_New_Line;
         Put_New_Line;

         S_Put
           (0,
            "end "
            & P.Name_TD.all
            & ";");
         Close_File;
      end loop;

      Generate_Common_Harness_Files;

   end Generate_Test_Driver_Projects;

   -----------------------------------
   -- Generate_Common_Harness_Files --
   -----------------------------------

   procedure Generate_Common_Harness_Files is
      P : Separate_Project_Info;

      procedure Generate_Aggregate_Project;
      --  Create aggregate project that incorparates all test driver projects.

      function Path_To_Unix (S : String) return String;
      --  Replace all "\" with "/".

      procedure Generate_Aggregate_Project is
      begin
         Create (Harness_Dir.all & "test_drivers.gpr");

         S_Put (0, "with ""gnattest_common.gpr"";");
         Put_New_Line;
         Put_New_Line;
         S_Put (0, "aggregate project Test_Drivers is");
         Put_New_Line;
         S_Put (3, "for Project_Files use");
         Put_New_Line;

         if Separate_Projects.Length = Ada.Containers.Count_Type (1) then
            P := Separate_Projects.First_Element;

            declare
               Pth : constant String :=
                 +Relative_Path
                 (Create (+P.Path_TD.all),
                  Create (+Harness_Dir.all));
            begin
               S_Put (5, "(""" & Pth & """);");
            end;
            Put_New_Line;
         else
            for
              K in Separate_Projects.First_Index ..
                Separate_Projects.Last_Index
            loop
               P := Separate_Projects.Element (K);
               declare
                  Pth : constant String :=
                    +Relative_Path
                    (Create (+P.Path_TD.all),
                     Create (+Harness_Dir.all));
               begin
                  if K = Separate_Projects.First_Index then
                     S_Put (5, "(""" & Pth & """,");
                  elsif K = Separate_Projects.Last_Index then
                     S_Put (6, """" & Pth & """);");
                  else
                     S_Put (6, """" & Pth & """,");
                  end if;
               end;
               Put_New_Line;
            end loop;
         end if;

         Put_New_Line;
         S_Put
           (3,
            "for Origin_Project use """
            & (+Relative_Path
                 (Create (+Source_Prj.all),
                   Create (+Normalize_Pathname (Harness_Dir.all))))
            & """;");
         Put_New_Line;
         Put_New_Line;
         S_Put (3, "for Target use Gnattest_Common'Target;");
         Put_New_Line;
         S_Put
           (3,
            "for Runtime (""Ada"") use Gnattest_Common'Runtime (""Ada"");");
         Put_New_Line;
         Put_New_Line;
         S_Put (3, "package Builder renames Gnattest_Common.Builder;");
         Put_New_Line;
         Put_New_Line;
         S_Put (3, "package GNATtest is");
         Put_New_Line;
         S_Put (3, "for GNATTest_Mapping_File use ""gnattest.xml"";");
         Put_New_Line;
         S_Put (3, "end GNATtest;");
         Put_New_Line;
         Put_New_Line;

         S_Put (0, "end Test_Drivers;");

         Close_File;
      end Generate_Aggregate_Project;

      function Path_To_Unix (S : String) return String is
         S1 : String := (S);
      begin
         for I in S1'Range loop
            if S1 (I) = '\' then
               S1 (I) := '/';
            end if;
         end loop;

         return S1;
      end Path_To_Unix;

   begin
      Generate_Gnattest_Common_Prj;

      --  Makefile
      Create (Harness_Dir.all & "Makefile");
      S_Put (0, "# Check if we are running on Windows");
      Put_New_Line;
      S_Put (0, "ifeq ($(OS),Windows_NT)");
      Put_New_Line;
      S_Put (0,
             ASCII.HT
             & "EXE_EXT=.exe");
      Put_New_Line;
      S_Put (0, "else");
      Put_New_Line;
      S_Put (0,
             ASCII.HT
             & "EXE_EXT=");
      Put_New_Line;
      S_Put (0, "endif");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "# Executables");
      Put_New_Line;
      S_Put (0, "GPRBUILD=gprbuild");
      Put_New_Line;
      S_Put (0, "GPRCLEAN=gprclean");
      Put_New_Line;
      S_Put (0, "GNATCOV=gnatcov");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "# Number of processes used to build");
      Put_New_Line;
      S_Put (0, "# (default 0 is using maximum available cores)");
      Put_New_Line;
      S_Put (0, "NUMPROC=0");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "# Switches for gprbuild");
      Put_New_Line;
      S_Put
        (0,
         "# To be defined if there is a specific target and/or runtime, etc");
      Put_New_Line;
      S_Put (0, "BUILDERFLAGS=");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "# Project-specific switches");
      Put_New_Line;
      S_Put (0, "# To be defined to customize the build");
      Put_New_Line;
      S_Put (0, "GPRFLAGS=");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "# List of projects to build");
      Put_New_Line;
      S_Put (0, "PRJS = \");
      Put_New_Line;

      for
        K in Separate_Projects.First_Index .. Separate_Projects.Last_Index
      loop
         P := Separate_Projects.Element (K);
         declare
            Rel_Pth : constant Filesystem_String :=
              Relative_Path
                (Create (+P.Path_TD.all),
                 Create (+Harness_Dir.all));
            Pth : constant String :=
              (if Driver_Per_Unit then +Dir_Name (Rel_Pth) else +Rel_Pth);
         begin
            S_Put
                (0,
                 ASCII.HT
                 & Path_To_Unix (Pth)
                 & (if K = Separate_Projects.Last_Index then "" else " \"));
         end;
         Put_New_Line;
      end loop;

      Put_New_Line;
      S_Put (0, "CKPTS = $(patsubst %,%-gnatcov-cov,$(PRJS))");
      Put_New_Line;
      S_Put (0, "GNATCOV_LEVEL=stmt+decision");
      Put_New_Line;
      S_Put (0, "GNATCOV_OUTPUT_FMT=dhtml --output-dir=dhtml-report");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, ".PHONY: all");
      Put_New_Line;
      Put_New_Line;

      S_Put (0, "all: $(patsubst %,%-build,$(PRJS))");
      Put_New_Line;
      Put_New_Line;

      if Driver_Per_Unit then
         S_Put (0, "%-build: %/test_driver.gpr");
      else
         S_Put (0, "%-build: %");
      end if;
      Put_New_Line;
      S_Put
        (0,
         ASCII.HT
         & "$(GPRBUILD) $(BUILDERFLAGS) -P$< $(GPRFLAGS) -gargs -j$(NUMPROC)");
      Put_New_Line;
      Put_New_Line;

      if Driver_Per_Unit then
         S_Put (0, "%-build-cov: %/test_driver.gpr");
         Put_New_Line;
         S_Put
           (0,
            ASCII.HT
            & "$(GPRBUILD) $(BUILDERFLAGS) -P$< $(GPRFLAGS) -gargs "
            & "-j$(NUMPROC) -cargs -g -fdump-scos -fpreserve-control-flow");
         Put_New_Line;
         Put_New_Line;

         S_Put (0, "%-gnatcov-run: %-build-cov");
         Put_New_Line;
         S_Put
           (0,
            ASCII.HT
            & "$(GNATCOV) run --level=$(GNATCOV_LEVEL) -P$*/test_driver.gpr "
            & " $*/*-test_runner$(EXE_EXT) -o $*-gnattest.trace");
         Put_New_Line;
         Put_New_Line;

         S_Put (0, "%-gnatcov-cov: %-gnatcov-run");
         Put_New_Line;
         S_Put
           (0,
            ASCII.HT
            & "$(GNATCOV) coverage --save-checkpoint=$*-gnattest.ckpt "
            & "--level=$(GNATCOV_LEVEL) "
            & "-P$*/test_driver.gpr $*-gnattest.trace");
         Put_New_Line;
         Put_New_Line;

         S_Put (0, "gnatcov-consolidate: $(CKPTS)");
         Put_New_Line;
         declare
            Pth : constant String :=
              +Relative_Path
              (Create (+Source_Prj.all),
               Create (+Harness_Dir.all));
         begin
            S_Put
              (0,
               ASCII.HT
               & "$(GNATCOV) coverage -P"
               & Path_To_Unix (Pth)
               & " $(patsubst %,-C "
               & "%-gnattest.ckpt,$(PRJS)) -a $(GNATCOV_OUTPUT_FMT) "
               & "--level=$(GNATCOV_LEVEL)");
         end;
         Put_New_Line;
         Put_New_Line;

         S_Put (0, "coverage: gnatcov-consolidate");
         Put_New_Line;
         Put_New_Line;
      end if;

      S_Put (0, "clean: $(patsubst %,%-clean,$(PRJS))");
      Put_New_Line;
      Put_New_Line;

      if Driver_Per_Unit then
         S_Put (0, "%-clean: %/test_driver.gpr");
      else
         S_Put (0, "%-clean: %");
      end if;
      Put_New_Line;
      S_Put
        (0,
         ASCII.HT
         & "$(GPRCLEAN) $(BUILDERFLAGS) -P$<");
      Put_New_Line;

      Close_File;

      --  suppress.adc & suppress_no_ghost.adc
      Generate_Global_Config_Pragmas_File;

      --  Executable list
      Create (Harness_Dir.all & "test_drivers.list");

      declare
         Exe_Suffix : String_Access := Get_Target_Executable_Suffix;
      begin
         for
           K in Separate_Projects.First_Index .. Separate_Projects.Last_Index
         loop
            P := Separate_Projects.Element (K);

            S_Put
              (0,
               Dir_Name (P.Path_TD.all)
               & Base_Name (P.Main_File_Name.all, ".adb")
               & Exe_Suffix.all);
            Put_New_Line;
         end loop;

         Free (Exe_Suffix);
      end;

      Close_File;

      Generate_Aggregate_Project;
   end Generate_Common_Harness_Files;

   -----------------------------------------
   -- Generate_Global_Config_Pragmas_File --
   -----------------------------------------

   procedure Generate_Global_Config_Pragmas_File is
   begin
      if not Is_Regular_File (Harness_Dir.all & "suppress.adc") then
         Create (Harness_Dir.all & "suppress.adc");
         S_Put (0, "pragma Assertion_Policy (Pre => Ignore);");
         Put_New_Line;
         S_Put (0, "pragma Assertion_Policy (Post => Ignore);");
         Put_New_Line;
         S_Put (0, "pragma Assertion_Policy (Ghost => Check);");
         Put_New_Line;
         Close_File;
      end if;

      if not Is_Regular_File (Harness_Dir.all & "suppress_no_ghost.adc") then
         Create (Harness_Dir.all & "suppress_no_ghost.adc");
         S_Put (0, "pragma Assertion_Policy (Pre => Ignore);");
         Put_New_Line;
         S_Put (0, "pragma Assertion_Policy (Post => Ignore);");
         Put_New_Line;
         Close_File;
      end if;
   end Generate_Global_Config_Pragmas_File;

   ----------------------------------
   -- Generate_Gnattest_Common_Prj --
   ----------------------------------

   procedure Generate_Gnattest_Common_Prj is
      Gnattest_Common_Prj : constant String := Gnattest_Common_Prj_Name;
   begin
      if Is_Regular_File (Gnattest_Common_Prj) then
         return;
      end if;
      Create (Gnattest_Common_Prj);

      S_Put (0, "abstract project Gnattest_Common is");
      Put_New_Line;
      S_Put (3, "for Languages use (""Ada"");");
      Put_New_Line;
      S_Put (3, "for Source_Files use ();");
      Put_New_Line;

      if GNATtest.Options.RTS_Path.all /= "" then
         if RTS_Attribute_Val = null then
            S_Put (3, "for Runtime (""Ada"") use """ &
                     GNATtest.Options.RTS_Path.all & """;");
         else
            S_Put
              (3,
               "for Runtime (""Ada"") use """ & RTS_Attribute_Val.all & """;");
         end if;
         Put_New_Line;
      end if;

      declare
         Firts_Idx : constant Natural := ASIS_UL.Common.Tool_Name'First;
         Last_Idx  : constant Natural :=
           Index (ASIS_UL.Common.Tool_Name.all, "-", Ada.Strings.Backward);
      begin
         if Last_Idx /= 0 then
            S_Put
              (3,
               "for Target use """
               & ASIS_UL.Common.Tool_Name (Firts_Idx .. Last_Idx - 1)
               & """;");
            Put_New_Line;
         end if;
      end;

      Put_New_Line;
      S_Put
        (3,
         "type TD_Compilation_Type is (""contract-checks"","
         & """no-contract-checks"", ""no-config-file"");");
      Put_New_Line;
      if Has_Test_Cases then
         S_Put
           (3,
            "TD_Compilation : TD_Compilation_Type := external "
            & "(""TEST_DRIVER_BUILD_MODE"", ""contract-checks"");");
      else
         S_Put
           (3,
            "TD_Compilation : TD_Compilation_Type := external "
            & "(""TEST_DRIVER_BUILD_MODE"", ""no-config-file"");");
      end if;
      Put_New_Line;

      Put_New_Line;
      S_Put (3, "package Builder is");
      Put_New_Line;
      S_Put (6, "case TD_Compilation is");
      Put_New_Line;
      S_Put (9, "when ""contract-checks"" =>");
      Put_New_Line;
      S_Put (12, "for Global_Configuration_Pragmas use ""suppress.adc"";");
      Put_New_Line;
      S_Put (9, "when ""no-contract-checks"" =>");
      Put_New_Line;
      S_Put
        (12,
         "for Global_Configuration_Pragmas use ""suppress_no_ghost.adc"";");
      Put_New_Line;
      S_Put (9, "when ""no-config-file"" =>");
      Put_New_Line;
      S_Put (12, "null;");
      Put_New_Line;
      S_Put (6, "end case;");
      Put_New_Line;
      S_Put (3, "end Builder;");
      Put_New_Line;
      Put_New_Line;

      S_Put (3, "package Linker is");
      Put_New_Line;
      S_Put (6, "for Default_Switches (""ada"") use (""-g"");");
      Put_New_Line;
      S_Put (3, "end Linker;");
      Put_New_Line;
      Put_New_Line;

      S_Put (3, "package Binder is");
      Put_New_Line;
      S_Put (6, "for Default_Switches (""ada"") use (""-E"", ""-static"");");
      Put_New_Line;
      S_Put (3, "end Binder;");
      Put_New_Line;
      Put_New_Line;

      S_Put (3, "Contract_Switches := ();");
      Put_New_Line;
      S_Put (3, "case TD_Compilation is");
      Put_New_Line;
      S_Put (6, "when ""contract-checks"" =>");
      Put_New_Line;
      S_Put (9, "Contract_Switches := (""-gnata"");");
      Put_New_Line;
      S_Put (6, "when others =>");
      Put_New_Line;
      S_Put (9, "null;");
      Put_New_Line;
      S_Put (3, "end case;");
      Put_New_Line;

      S_Put (3, "package Compiler is");
      Put_New_Line;
      S_Put (6, "for Default_Switches (""ada"") use");
      Put_New_Line;
      S_Put (8, "(""-g"", ""-gnatyM0""");
      declare
         Cur : List_Of_Strings.Cursor := Inherited_Switches.First;
      begin
         loop
            exit when Cur = List_Of_Strings.No_Element;
            S_Put (0, ", """ & List_Of_Strings.Element (Cur) & """");
            List_Of_Strings.Next (Cur);
         end loop;
         Inherited_Switches.Clear;
      end;
      S_Put (0, ") & Contract_Switches;");
      Put_New_Line;
      S_Put (3, "end Compiler;");
      Put_New_Line;
      Put_New_Line;

      if Stub_Mode_ON or else Separate_Drivers then
         S_Put (3, "package Ide is");
         Put_New_Line;
         S_Put (3, "end Ide;");
         Put_New_Line;
         S_Put (3, "package Make is");
         Put_New_Line;
         S_Put (3, "end Make;");
         Put_New_Line;
      end if;

      S_Put (0, "end Gnattest_Common;");
      Put_New_Line;
      Close_File;
   end Generate_Gnattest_Common_Prj;

   ----------------------------------------
   -- Generate_Stub_Test_Driver_Projects --
   ----------------------------------------

   procedure Generate_Stub_Test_Driver_Projects is
      P : Separate_Project_Info;

      Imported : List_Of_Strings.List;
      I_Cur    : List_Of_Strings.Cursor;
      S_Cur    : List_Of_Strings.Cursor;

      Tmp, Current_Infix : String_Access;

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

      Out_Dirs     : Srcs.Set;
      Out_Dirs_Cur : Srcs.Cursor;

      procedure Add_Nesting_Hierarchy_Dummies (S : String);
      --  For nested packages corresponding test packages are children to a
      --  dummy hierarchy replicating the original package nesting and
      --  descending from top-level test project. All those dummy packages
      --  should also be included as test driver source files.
      --  Analyzes test package name and acts accordingly.

      procedure Add_Nesting_Hierarchy_Dummies (S : String) is
         Idx, Idx2 : Integer;
      begin
         Idx := Index (S, Test_Data_Unit_Name);
         Idx2 := Index (S, Test_Data_Unit_Name, Idx + 1);

         if Idx2 = 0 then
            --  Not a nested test package.
            return;
         end if;

         Idx2 := Index (S, ".", Idx);
         if not
           Excluded_Test_Package_Bodies.Contains
             (Unit_To_File_Name
                (S (S'First .. Idx2 - 1)) & ".adb")
         then
            S_Put
              (6,
               """"
               & Unit_To_File_Name
                 (S (S'First .. Idx2 - 1))
               & ".adb"",");
            Put_New_Line;
         end if;
         S_Put
              (6,
               """"
               & Unit_To_File_Name
                 (S (S'First .. Idx2 - 1))
               & ".ads"",");
         Put_New_Line;

         Idx2 := Index (S, ".", Idx2 + 1);
         if not
           Excluded_Test_Package_Bodies.Contains
             (Unit_To_File_Name
                (S (S'First .. Idx2 - 1)) & ".adb")
         then
            S_Put
              (6,
               """"
               & Unit_To_File_Name
                 (S (S'First .. Idx2 - 1))
               & ".adb"",");
            Put_New_Line;
         end if;
         S_Put
              (6,
               """"
               & Unit_To_File_Name
                 (S (S'First .. Idx2 - 1))
               & ".ads"",");
         Put_New_Line;

         loop
            Idx2 := Index (S, ".", Idx2 + 1);
            S_Put
              (6,
               """"
               & Unit_To_File_Name
                 (S (S'First .. Idx2 - 1))
               & ".ads"",");
            Put_New_Line;

            if
              Index (S, ".", Idx2 + 1) >
              Index (S, Test_Data_Unit_Name, Idx2 + 1)
            then
               --  Next package is the original test data one.
               exit;
            end if;
         end loop;
      end Add_Nesting_Hierarchy_Dummies;

   begin
      Trace (Me, "Generate_Stub_Test_Driver_Projects");
      Increase_Indent (Me);

      if Separate_Projects.Is_Empty then
         Report_Std
           ("gnattest: no test skeletons generated because "
            & "no subprogram to test");
         Report_Std
           ("found in project " & Source_Prj.all, 10);
         Report_Std ("cannot create main suite and test runner", 10);
         raise Fatal_Error;
      end if;

      if Stub_Mode_ON then
         GNATtest.Skeleton.Source_Table.Mark_Projects_With_Stubbed_Sources;
      end if;

      for
        K in Separate_Projects.First_Index .. Separate_Projects.Last_Index
      loop
         P := Separate_Projects.Element (K);

         Current_Infix := new String'(Get_Next_Infix);
         if Stub_Exclusion_Lists.Contains (Base_Name (P.UUT_File_Name.all))
         then
            GNATtest.Skeleton.Source_Table.Enforce_Custom_Project_Extention
              (P.UUT_File_Name.all, P.Path_Extending.all, Current_Infix.all);
         else
            GNATtest.Skeleton.Source_Table.Enforce_Project_Extention
              (P.Name_Of_Extended.all,
               P.Path_Extending.all,
               Current_Infix.all);
         end if;

         --  Extending project
         Create (P.Path_Extending.all);

         if Stub_Mode_ON then
            Imported :=
              GNATtest.Skeleton.Source_Table.Get_Imported_Projects
                (P.Name_Of_Extended.all);

            I_Cur := Imported.First;
            while I_Cur /= List_Of_Strings.No_Element loop
               if
                 GNATtest.Skeleton.Source_Table.Project_Extended
                   (List_Of_Strings.Element (I_Cur))
               then
                  Tmp := new String'(List_Of_Strings.Element (I_Cur));
                  declare
                     Imported_Stubbed_Path : constant String :=
                       GNATtest.Skeleton.Source_Table.Get_Project_Stub_Dir
                         (Tmp.all)
                       & Directory_Separator
                       & Unit_To_File_Name
                           (Stub_Project_Prefix & Current_Infix.all & Tmp.all)
                       & ".gpr";
                     Relative_P : constant String :=
                       +Relative_Path
                          (Create (+Imported_Stubbed_Path),
                           Create (+Dir_Name (P.Path_Extending.all)));
                  begin
                     S_Put
                       (0,
                        "with """
                        & Relative_P
                        & """;");
                     Put_New_Line;
                  end;
               end if;

               Free (Tmp);

               Next (I_Cur);
            end loop;
         end if;

         S_Put
           (0,
            "with """
              & (+Relative_Path
                 (Create (+Gnattest_Common_Prj_Name),
                   Create (+Dir_Name (P.Path_Extending.all))))
            & """;");
         Put_New_Line;
         Put_New_Line;
         S_Put
           (0,
            "project "
            & P.Name_Extending.all
            & " extends """
            & P.Path_Of_Extended.all
            & """ is");
         Put_New_Line;

         S_Put (3, "for Target use Gnattest_Common'Target;");
         Put_New_Line;
         Put_New_Line;
         S_Put
           (3,
            "for Runtime (""Ada"") use Gnattest_Common'Runtime (""Ada"");");
         Put_New_Line;
         Put_New_Line;
         S_Put (3, "package Ide renames Gnattest_Common.Ide;");
         Put_New_Line;
         Put_New_Line;
         S_Put (3, "package Make renames Gnattest_Common.Make;");
         Put_New_Line;
         Put_New_Line;

         S_Put (3, "for Languages use Gnattest_Common'Languages & (""Ada"");");
         Put_New_Line;

         declare
            Dir : File_Array_Access;
         begin
            Append
              (Dir,
               GNATCOLL.VFS.Create
                 (+(Dir_Name (P.Path_Extending.all)
                  & Directory_Separator
                  & P.Name_Extending.all
                  & "_lib")));
            Append
              (Dir,
               GNATCOLL.VFS.Create
                 (+(Dir_Name (P.Path_Extending.all)
                  & Directory_Separator
                  & P.Name_Extending.all
                  & "_obj")));
            Create_Dirs (Dir);
         exception
            when Directory_Error =>
               Report_Err
                 ("gnattest: cannot create obj/lib directory for "
                  & P.Path_Extending.all);
               raise Fatal_Error;
         end;

         S_Put
           (3,
            "for Library_Dir use """
            & P.Name_Extending.all
            & "_lib"";");
         Put_New_Line;
         S_Put
           (3,
            "for Object_Dir use """
            & P.Name_Extending.all
            & "_obj"";");
         Put_New_Line;
         Put_New_Line;
         if  P.Stub_Source_Dir = null then
            S_Put (3, "for Source_Dirs use ();");
         else

            S_Put
              (3,
               "for Source_Dirs use ("""
               & P.Stub_Source_Dir.all
               & """);");
         end if;
         Put_New_Line;
         Put_New_Line;

         S_Cur := P.Sources_List.First;
         if S_Cur /= List_Of_Strings.No_Element then
            S_Put (3, "for Source_Files use");
            Put_New_Line;

            while S_Cur /= List_Of_Strings.No_Element loop

               if S_Cur = P.Sources_List.First then
                  S_Put
                    (5,
                     "("""
                     & Base_Name (List_Of_Strings.Element (S_Cur))
                     & """");
               else
                  S_Put
                    (6,
                     """"
                     & Base_Name (List_Of_Strings.Element (S_Cur))
                     & """");
               end if;

               Next (S_Cur);

               if S_Cur = List_Of_Strings.No_Element then
                  S_Put (0, ");");
               else
                  S_Put (0, ",");
               end if;

               Put_New_Line;

            end loop;
         end if;

         S_Put (3, "package Compiler renames Gnattest_Common.Compiler;");

         Put_New_Line;
         Put_New_Line;

         S_Put
           (0,
            "end "
            & P.Name_Extending.all
            & ";");
         Close_File;

         --  Test driver project
         Create (P.Path_TD.all);

         S_Put (0, "with ""aunit"";");
         Put_New_Line;
         S_Put
           (0,
            "with """
              & (+Relative_Path
                 (Create (+Gnattest_Common_Prj_Name),
                   Create (+Dir_Name (P.Path_TD.all))))
            & """;");
         Put_New_Line;
         S_Put
           (0,
            "with """
            & Base_Name (P.Path_Extending.all)
            & """;");
         Put_New_Line;
         Put_New_Line;

         S_Put
           (0,
            "project "
            & P.Name_TD.all
            & " is");
         Put_New_Line;
         S_Put
           (3,
            "for Origin_Project use """
            & (+Relative_Path
                 (Create (+P.Path_Of_Extended.all),
                   Create (+Normalize_Pathname (Dir_Name (P.Path_TD.all)))))
            & """;");
         Put_New_Line;
         Put_New_Line;

         S_Put (3, "for Languages use Gnattest_Common'Languages & (""Ada"");");
         Put_New_Line;

         S_Put (3, "for Target use Gnattest_Common'Target;");
         Put_New_Line;
         Put_New_Line;
         S_Put
           (3,
            "for Runtime (""Ada"") use Gnattest_Common'Runtime (""Ada"");");
         Put_New_Line;
         Put_New_Line;
         S_Put (3, "package Ide renames Gnattest_Common.Ide;");
         Put_New_Line;
         Put_New_Line;
         S_Put (3, "package Make renames Gnattest_Common.Make;");
         Put_New_Line;
         Put_New_Line;

         S_Put
           (3,
            "for Main use ("""
            & P.Main_File_Name.all
            & """);");
         Put_New_Line;
         S_Put (3, "for Exec_Dir use ""."";");
         Put_New_Line;

         declare
            Dir : File_Array_Access;
         begin
            Append
              (Dir,
               GNATCOLL.VFS.Create
                 (+(Dir_Name (P.Path_TD.all)
                  & Directory_Separator
                  & P.Name_TD.all
                  & "_obj")));
            Create_Dirs (Dir);
         exception
            when Directory_Error =>
               Report_Err
                 ("gnattest: cannot create obj directory for "
                  & P.Path_TD.all);
               raise Fatal_Error;
         end;

         S_Put
           (3,
            "for Object_Dir use """
            & P.Name_TD.all
            & "_obj"";");
         Put_New_Line;

         GNATtest.Skeleton.Source_Table.Reset_Source_Iterator;
         loop
            Tmp := new String'
              (GNATtest.Skeleton.Source_Table.Next_Source_Name);
            exit when Tmp.all = "";

            if
              Is_Directory
                (GNATtest.Skeleton.Source_Table.Get_Source_Output_Dir
                   (Tmp.all))
            then
               Include
                 (Out_Dirs,
                  GNATtest.Skeleton.Source_Table.Get_Source_Output_Dir
                    (Tmp.all));
            end if;
            Free (Tmp);
         end loop;

         S_Put (3, "for Source_Dirs use");
         Put_New_Line;

         if Out_Dirs.Is_Empty then
            S_Put (5, "(""../common"", ""."");");

            Put_New_Line;
            Put_New_Line;
         else
            Out_Dirs_Cur := Out_Dirs.First;
            S_Put (5, "(""");
            S_Put
              (0,
               +Relative_Path
                 (Create (+Srcs.Element (Out_Dirs_Cur)),
                  Create (+Dir_Name (P.Path_TD.all))) &
                 """");
            loop
               Srcs.Next (Out_Dirs_Cur);
               exit when Out_Dirs_Cur = Srcs.No_Element;

               S_Put (0, ",");
               Put_New_Line;
               S_Put (6, """");
               S_Put
                 (0,
                  +Relative_Path
                    (Create (+Srcs.Element (Out_Dirs_Cur)),
                     Create (+Dir_Name (P.Path_TD.all))) &
                    """");

            end loop;
            S_Put (0, ",");
            Put_New_Line;
            S_Put (6, """../common"", ""."");");

            Put_New_Line;
            Put_New_Line;
         end if;

         if Stub_Mode_ON then
            S_Put
              (3, "for Source_Files use");
            Put_New_Line;
            S_Put
              (5, "(""gnattest_generated.ads"",");
            Put_New_Line;
            S_Put
              (6,
               """"
               & P.Main_File_Name.all
               & """,");
            Put_New_Line;
            Add_Nesting_Hierarchy_Dummies (P.Test_Package.all);
            S_Put
              (6,
               """"
               & Unit_To_File_Name
                 (P.Test_Package.all)
               & ".adb"",");
            Put_New_Line;
            S_Put
              (6,
               """"
               & Unit_To_File_Name
                 (P.Test_Package.all)
               & ".ads"",");
            Put_New_Line;
            if Driver_Per_Unit then
               S_Put
                 (6,
                  """"
                  & Unit_To_File_Name
                    (P.Test_Package.all & ".Suite")
                  & ".adb"",");
               Put_New_Line;
               S_Put
                 (6,
                  """"
                  & Unit_To_File_Name
                    (P.Test_Package.all & ".Suite")
                  & ".ads"",");
               Put_New_Line;
            end if;
            S_Put
              (6,
               """"
               & Unit_To_File_Name
                 (P.Test_Data.all)
               & ".adb"",");
            Put_New_Line;
            S_Put
              (6,
               """"
               & Unit_To_File_Name
                 (P.Test_Data.all)
               & ".ads"");");
            Put_New_Line;
            Put_New_Line;
         end if;

         S_Put (3, "package Builder renames Gnattest_Common.Builder;");
         Put_New_Line;
         S_Put (3, "package Linker renames Gnattest_Common.Linker;");
         Put_New_Line;
         S_Put (3, "package Binder renames Gnattest_Common.Binder;");
         Put_New_Line;
         S_Put (3, "package Compiler renames Gnattest_Common.Compiler;");
         Put_New_Line;
         Put_New_Line;

         S_Put
           (0,
            "end "
            & P.Name_TD.all
            & ";");
         Close_File;
         Free (Current_Infix);
      end loop;

      Generate_Common_Harness_Files;

      Decrease_Indent (Me, "done");
   end Generate_Stub_Test_Driver_Projects;

   ----------------------
   --  Generate_Suite  --
   ----------------------

   procedure Generate_Suite (Data : Data_Holder; Path : String := "") is
      New_Unit_Name : String_Access;

      Current_Type : Test_Type_Info;

      File_Destination : constant String :=
        (if Path = "" then Harness_Dir.all else Path);
   begin

      if Data.Generic_Kind then

         New_Unit_Name := new String'(Data.Test_Unit_Full_Name.all &
                                      "."                          &
                                      Generic_Suite_Name);
      else

         New_Unit_Name := new String'(Data.Test_Unit_Full_Name.all &
                                      "."                          &
                                      Common_Suite_Name);
      end if;

      --  Creating test suite spec
      Create (File_Destination
              & Unit_To_File_Name (New_Unit_Name.all)
              & ".ads");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      Put_New_Line;

      S_Put (0, "with AUnit.Test_Suites;");
      if Data.Generic_Kind then
         S_Put (1, "use AUnit.Test_Suites;");
         Put_New_Line;
         S_Put (0, "with AUnit.Test_Caller;");
      end if;
      Put_New_Line;
      Put_New_Line;

      if Data.Generic_Kind then
         S_Put (0, "generic");
         Put_New_Line;
         S_Put (3, "Instance_Name : String;");
         Put_New_Line;
      end if;

      S_Put (0, "package " & New_Unit_Name.all & " is");
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "function Suite return AUnit.Test_Suites.Access_Test_Suite;");
      Put_New_Line;
      Put_New_Line;

      if Data.Generic_Kind then

         for
           I in Data.Test_Types.First_Index .. Data.Test_Types.Last_Index
         loop
            S_Put (3, "package Runner_" & Positive_Image (I));
            S_Put (0, " is new AUnit.Test_Caller");
            Put_New_Line;

            S_Put (5,
                   "("                           &
                   Data.Test_Unit_Full_Name.all  &
                   "."                           &
                   Data.Test_Types.Element (I).Test_Type_Name.all &
                   ");");
            Put_New_Line;
            Put_New_Line;
         end loop;

         for K in Data.TR_List.First_Index .. Data.TR_List.Last_Index loop

            S_Put (3,
                   Data.TR_List.Element (K).TR_Text_Name.all &
                   "_" &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   "_Access : constant Runner_" &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   ".Test_Method :=");
            Put_New_Line;
            S_Put (5,
                   Data.TR_List.Element (K).TR_Text_Name.all &
                   "'Access;");
            Put_New_Line;

         end loop;

         for K in Data.ITR_List.First_Index .. Data.ITR_List.Last_Index loop

            S_Put
              (3,
               Data.ITR_List.Element (K).TR_Text_Name.all &
               "_" &
               Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
               "_Access : constant Runner_" &
               Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
               ".Test_Method :=");
            Put_New_Line;
            S_Put (5,
                   Data.ITR_List.Element (K).TR_Text_Name.all &
                   "'Access;");
            Put_New_Line;

         end loop;

         Put_New_Line;

      end if;

      S_Put (0, "end " & New_Unit_Name.all & ";");
      Put_New_Line;
      S_Put (0, GT_Marker_End);
      Put_New_Line;
      Close_File;

      --  Creating test suite body
      Create (File_Destination                      &
              Unit_To_File_Name (New_Unit_Name.all) &
              ".adb");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      Put_New_Line;

      if not Data.Generic_Kind then
         S_Put (0, "with AUnit.Test_Caller;");
      end if;
      Put_New_Line;
      S_Put (0, "with Gnattest_Generated;");
      Put_New_Line;
      Put_New_Line;
      S_Put (0,
             "package body "     &
             New_Unit_Name.all   &
             " is");
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "use AUnit.Test_Suites;");
      Put_New_Line;
      Put_New_Line;

      if not Data.Generic_Kind then

         for
           I in Data.Test_Types.First_Index .. Data.Test_Types.Last_Index
         loop
            Current_Type := Data.Test_Types.Element (I);

            S_Put (3, "package Runner_" & Positive_Image (I));
            S_Put (0, " is new AUnit.Test_Caller");
            Put_New_Line;

            if
              Nesting_Difference
                (Current_Type.Nesting.all,
                 Data.Test_Unit_Full_Name.all) = ""
            then
               S_Put (5,
                      "(GNATtest_Generated.GNATtest_Standard." &
                      Data.Test_Unit_Full_Name.all    &
                      "."                             &
                      Current_Type.Test_Type_Name.all &
                      ");");
            else
               S_Put
                 (5,
                  "(GNATtest_Generated.GNATtest_Standard."     &
                  Data.Test_Unit_Full_Name.all     &
                  "."                              &
                  Nesting_Difference
                    (Current_Type.Nesting.all,
                     Data.Test_Unit_Full_Name.all) &
                  "."                              &
                  Current_Type.Test_Type_Name.all  &
                  ");");
            end if;

            Put_New_Line;
            Put_New_Line;
         end loop;

         S_Put (3, "Result : aliased AUnit.Test_Suites.Test_Suite;");

         Put_New_Line;
         Put_New_Line;

      end if;

      --  Declaring test cases for test routines

      --  Test case variables recieve unique numbers in order to
      --  escape name collisions for cases when test routines with
      --  same name and same test type are declared in different
      --  nested packages.

      for K in Data.TR_List.First_Index .. Data.TR_List.Last_Index loop

         if Data.Generic_Kind then

            S_Put (3,
                   Test_Case_Prefix                                         &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   "_"                                                      &
                   Data.TR_List.Element (K).TR_Text_Name.all                &
                   " : Runner_"                                             &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   ".Test_Case_Access;");
         else

            S_Put (3,
                   Test_Case_Prefix                                         &
                   Positive_Image (K)                                       &
                   "_"                                                      &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   "_"                                                      &
                   Data.TR_List.Element (K).TR_Text_Name.all                &
                   " : aliased Runner_"                                     &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   ".Test_Case;");
         end if;

         Put_New_Line;
      end loop;

      --  Declaring test cases for inherited test routines
      for K in Data.ITR_List.First_Index .. Data.ITR_List.Last_Index loop

         if Data.Generic_Kind then

            S_Put (3,
                   Test_Case_Prefix                                          &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   "i_"                                                      &
                   Data.ITR_List.Element (K).TR_Text_Name.all                &
                   " : Runner_"                                              &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   ".Test_Case_Access;");
         else

            S_Put (3,
                   Test_Case_Prefix                                          &
                   Positive_Image (K)                                        &
                   "i_"                                                      &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   "_"                                                       &
                   Data.ITR_List.Element (K).TR_Text_Name.all                &
                   " : aliased Runner_"                                      &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   ".Test_Case;");
         end if;

         Put_New_Line;

      end loop;

      Put_New_Line;
      S_Put (3,
             "function Suite return AUnit.Test_Suites.Access_Test_Suite is");
      Put_New_Line;
      if Data.Generic_Kind then
         S_Put (6, "Result : constant Access_Test_Suite := new Test_Suite;");
         Put_New_Line;
      end if;
      S_Put (3, "begin");
      Put_New_Line;
      Put_New_Line;

      --  Creating test cases for test routines
      for K in Data.TR_List.First_Index .. Data.TR_List.Last_Index loop

         if Data.Generic_Kind then

            S_Put (6,
                   Test_Case_Prefix                                         &
                   Positive_Image (K)                                       &
                   "_"                                                      &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   "_"                                                      &
                   Data.TR_List.Element (K).TR_Text_Name.all                &
                   " :=");
            Put_New_Line;
            S_Put (8,
                   "Runner_"                                                &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   ".Create");
            Put_New_Line;
            S_Put (10,
                   " (Instance_Name &");
            Put_New_Line;
            S_Put (11,
                   " "" : "                                  &
                   Data.TR_List.Element (K).TR_Text_Name.all &
                   """,");
            Put_New_Line;
            S_Put (11,
                   Data.TR_List.Element (K).TR_Text_Name.all                &
                   "_"                                                      &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   "_Access);");

         else

            S_Put (6,
                   "Runner_"                                                &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   ".Create");
            Put_New_Line;
            S_Put (8,
                   "("                                                      &
                   Test_Case_Prefix                                         &
                   Positive_Image (K)                                       &
                   "_"                                                      &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   "_"                                                      &
                   Data.TR_List.Element (K).TR_Text_Name.all                &
                   ",");
            Put_New_Line;
            S_Put (9,
                   """"
                   & Data.TR_List.Element (K).Tested_Sloc.all
                   & """,");
            Put_New_Line;
            if
              Nesting_Difference
                (Data.TR_List.Element (K).Nesting.all,
                 Data.Test_Unit_Full_Name.all) /= ""
            then
               S_Put
                 (9,
                  Nesting_Difference
                    (Data.TR_List.Element (K).Nesting.all,
                     Data.Test_Unit_Full_Name.all)          &
                  "."                                       &
                  Data.TR_List.Element (K).TR_Text_Name.all &
                  "'Access);");
            else
               S_Put (9,
                      Data.TR_List.Element (K).TR_Text_Name.all &
                      "'Access);");
            end if;

         end if;

         Put_New_Line;

      end loop;

      --  Creating test cases for inherited test routines
      for K in Data.ITR_List.First_Index .. Data.ITR_List.Last_Index loop

         Current_Type := Data.Test_Types.Element
           (Data.ITR_List.Element (K).Test_Type_Numb);

         if Data.Generic_Kind then

            S_Put (6,
                   Test_Case_Prefix                                          &
                   Positive_Image (K)                                        &
                   "i_"                                                      &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   "_"                                                       &
                   Data.ITR_List.Element (K).TR_Text_Name.all                &
                   " :=");
            Put_New_Line;
            S_Put (8,
                   "Runner_"                                                 &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   ".Create");
            Put_New_Line;
            S_Put (10, "(Instance_Name &");
            Put_New_Line;
            S_Put (11, """ (inherited from " &
                   Data.ITR_List.Element (K).TR_Rarent_Unit_Name.all    &
                   ") : "                                               &
                   Data.ITR_List.Element (K).TR_Text_Name.all           &
                   """,");
            Put_New_Line;
            S_Put (11,
                   Data.ITR_List.Element (K).TR_Text_Name.all                &
                   "_"                                                       &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   "_Access);");
         else

            S_Put (6,
                   "Runner_"                                                 &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   ".Create");
            Put_New_Line;
            S_Put (8,
                   "("                                                       &
                   Test_Case_Prefix                                          &
                   Positive_Image (K)                                        &
                   "i_"                                                      &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   "_"                                                       &
                   Data.ITR_List.Element (K).TR_Text_Name.all                &
                   ",");
            Put_New_Line;

            S_Put (9,
                   """"
                   & Data.ITR_List.Element (K).Tested_Sloc.all
                   & """,");
            Put_New_Line;
            if
              Nesting_Difference
                (Current_Type.Nesting.all, Data.Test_Unit_Full_Name.all) = ""
            then
               S_Put (9,
                      Data.ITR_List.Element (K).TR_Text_Name.all &
                      "'Access);");
            else
               S_Put
                 (9,
                  Nesting_Difference
                    (Current_Type.Nesting.all,
                     Data.Test_Unit_Full_Name.all)            &
                  "."                                         &
                   Data.ITR_List.Element (K).TR_Text_Name.all &
                  "'Access);");
            end if;

         end if;

         Put_New_Line;

      end loop;

      Put_New_Line;

      --  Adding test cases to the suite
      for K in Data.TR_List.First_Index .. Data.TR_List.Last_Index loop

         if Data.Generic_Kind then
            S_Put (6,
                   "Add_Test (Result'Access, "                               &
                   Test_Case_Prefix                                          &
                   Positive_Image (K)                                        &
                   "_"                                                       &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb)  &
                   "_"                                                       &
                   Data.TR_List.Element (K).TR_Text_Name.all                 &
                   ");");
         else
            S_Put (6,
                   "Add_Test (Result'Access, "                               &
                   Test_Case_Prefix                                          &
                   Positive_Image (K)                                        &
                   "_"                                                       &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb)  &
                   "_"                                                       &
                   Data.TR_List.Element (K).TR_Text_Name.all                 &
                   "'Access);");
         end if;

         Put_New_Line;

      end loop;

      --  Adding inherited test cases to the suite
      for K in Data.ITR_List.First_Index .. Data.ITR_List.Last_Index loop

         if Data.Generic_Kind then
            S_Put (6,
                   "Add_Test (Result'Access, "                               &
                   Test_Case_Prefix                                          &
                   Positive_Image (K)                                        &
                   "i_"                                                      &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   "_"                                                       &
                   Data.ITR_List.Element (K).TR_Text_Name.all                &
                   ");");
         else
            S_Put (6,
                   "Add_Test (Result'Access, "                               &
                   Test_Case_Prefix                                          &
                   Positive_Image (K)                                        &
                   "i_"                                                      &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   "_"                                                       &
                   Data.ITR_List.Element (K).TR_Text_Name.all                &
                   "'Access);");
         end if;

         Put_New_Line;

      end loop;

      Put_New_Line;

      for K in Data.TC_List.First_Index .. Data.TC_List.Last_Index loop
         S_Put
           (6,
            "Add_Test (Result'Access, new " &
            Data.TC_List.Element (K).Nesting.all &
            "." &
            Data.TC_List.Element (K).Name.all &
            ");");
         Put_New_Line;
      end loop;

      if Data.Generic_Kind then
         S_Put (6, "return Result;");
      else
         S_Put (6, "return Result'Access;");
      end if;
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "end Suite;");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "end " & New_Unit_Name.all & ";");
      Put_New_Line;
      S_Put (0, GT_Marker_End);
      Put_New_Line;
      Close_File;

      if not Data.Generic_Kind then
         List_Of_Strings.Append (Suit_List, New_Unit_Name.all);
      end if;

   end Generate_Suite;

   -------------------------------
   --  Generate_Suite_Instance  --
   -------------------------------

   procedure Generate_Suite_Instance (Data : Data_Holder) is

      New_Unit_Name        : constant String :=
        Data.Test_Unit_Full_Name.all & "." & Instant_Suite_Name;
      New_Substitution_Unit_Name : constant String :=
        Data.Test_Unit_Full_Name.all & "." & Substitution_Instant_Suite_Name;

      Generate_Substitution : Boolean := False;

      Cur : List_Of_Strings.Cursor;
   begin

      Create (Harness_Dir.all                    &
              Unit_To_File_Name (New_Unit_Name) &
              ".ads");

      S_Put (0,
             "with "                     &
             Data.Gen_Unit_Full_Name.all &
             "."                         &
             Generic_Suite_Name          &
             ";");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "package " & New_Unit_Name & " is new");
      Put_New_Line;
      S_Put (2,
             Data.Test_Unit_Full_Name.all &
             "."                          &
             Generic_Suite_Name           &
             " ("""                       &
             Data.Test_Unit_Full_Name.all &
             """);");

      Close_File;

      List_Of_Strings.Append (Suit_List, New_Unit_Name);

      Cur := Good_For_Substitution_Inst.First;
      loop
         exit when Cur = List_Of_Strings.No_Element;

         if Data.Gen_Unit_Full_Name.all = List_Of_Strings.Element (Cur) then
            Generate_Substitution := True;
         end if;

         List_Of_Strings.Next (Cur);
      end loop;

      if not Generate_Substitution then
         return;
      end if;

      Create (Harness_Dir.all                           &
              Unit_To_File_Name (New_Substitution_Unit_Name) &
              ".ads");

      S_Put (0,
             "with "                     &
             Data.Gen_Unit_Full_Name.all &
             "."                         &
             Generic_Substitution_Suite_Name   &
             ";");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "package " & New_Substitution_Unit_Name & " is new");
      Put_New_Line;
      S_Put (2,
             Data.Test_Unit_Full_Name.all &
             "."                          &
             Generic_Substitution_Suite_Name    &
             " ("""                       &
             Data.Test_Unit_Full_Name.all &
             """);");

      List_Of_Strings.Append (Suit_List, New_Substitution_Unit_Name);

      Close_File;

   end Generate_Suite_Instance;

   ---------------------
   --  Get_Subp_Name  --
   ---------------------

   function Get_Subp_Name (Subp : Asis.Element) return String is
      Idx  : Integer;
   begin

      Idx := Names (Subp)'First;

      return Trim (To_String (Defining_Name_Image (Names (Subp) (Idx))),
                   Both);

   end Get_Subp_Name;

   -------------------------
   --  Inheritance_Depth  --
   -------------------------

   function Inheritance_Depth
     (Current_Type_Decl   : Asis.Element;
      Parent_Type_Decl    : Asis.Element)
      return Natural
   is

      Type_Decl : Asis.Element := Current_Type_Decl;
      Count : Natural := 0;

   begin

      loop

         Type_Decl := Parent_Type_Declaration (Type_Decl);

         Count := Count + 1;

         exit when
           Is_Equal (Parent_Type_Decl, Type_Decl) or else
           Is_Equal (Parent_Type_Decl,
                     Corresponding_Type_Declaration (Type_Decl));

      end loop;

      return Count;

   end Inheritance_Depth;

   --------------------------
   --  Initialize_Context  --
   --------------------------

   function Initialize_Context (Source_Name : String) return Boolean is
      Success : Boolean;

      use type Asis.Errors.Error_Kinds; --  for EC12-013
   begin
      Create_Tree (Get_Source_Full_Name (Source_Name), Success);

      if not Success then
         Set_Source_Status (Source_Name, Bad_Source);

         Report_Std ("gnattest: " & Source_Name &
                     " is not a legal Ada source");
         Source_Compilation_Failed := True;

         return False;

      end if;

      Last_Context_Name :=
        new String'(Get_Source_Suffixless_Name (Source_Name));

      Associate
       (The_Context => The_Context,
        Name        => "",
        Parameters  => "-C1 "
        & To_Wide_String (Get_Source_Suffixless_Name (Source_Name) & ".adt"));

      begin
         Open (The_Context);
         Success := True;
      exception
         when ASIS_Failed =>
            --  The only known situation when we can not open a C1 context for
            --  newly created tree is recompilation of System (see D617-017)

            if Asis.Implementation.Status = Asis.Errors.Use_Error
              and then
               Asis.Implementation.Diagnosis = "Internal implementation error:"
               & " Asis.Ada_Environments.Open - System is recompiled"
            then
               Report_Err
                 ("gnattest: can not process redefinition of System in " &
                    Source_Name);

               Set_Source_Status (Source_Name, Bad_Source);
               Success := False;
            else
               raise;
            end if;

      end;

      return Success;

   end Initialize_Context;

   ---------------------
   --  Is_AUnit_Part  --
   ---------------------

   function Is_AUnit_Part (Unit : Compilation_Unit) return Boolean is
      Full_Name : String_Access;
      J         : Natural;
   begin

      Full_Name := new
        String'(Trim (To_String (Unit_Full_Name (Unit)), Both));

      J := Full_Name.all'First;

      loop

         if Full_Name.all (J) = '.' then
            exit;
         end if;

         exit when J = Full_Name.all'Last;

         J := J + 1;

      end loop;

      if Full_Name.all (Full_Name.all'First .. J - 1) = "AUnit" then
         return True;
      else
         return False;
      end if;

   end Is_AUnit_Part;

   ------------------
   -- Is_Test_Case --
   ------------------

   function Is_Test_Case (Type_Decl : Asis.Element) return Boolean is
      Dec_Elem, Def_Elem : Asis.Element;
   begin

      Dec_Elem := Type_Decl;

      loop

         if
           To_String (Defining_Name_Image (First_Name (Dec_Elem))) =
           "Test_Case"
         then
            if Is_AUnit_Part (Enclosing_Compilation_Unit (Dec_Elem)) then
               return True;
            end if;
         end if;

         Def_Elem := Type_Declaration_View (Dec_Elem);

         if Definition_Kind (Def_Elem) = A_Private_Extension_Definition then

            Dec_Elem := Corresponding_Type_Declaration (Dec_Elem);
            Def_Elem := Type_Declaration_View (Dec_Elem);
         end if;

         if Type_Kind (Def_Elem) = A_Tagged_Record_Type_Definition then
            exit;
         end if;

         if Definition_Kind (Def_Elem) = A_Tagged_Private_Type_Definition then
            Dec_Elem := Corresponding_Type_Declaration (Dec_Elem);
            exit;
         end if;

         Dec_Elem := Corresponding_Parent_Subtype (Def_Elem);

      end loop;

      return False;
   end Is_Test_Case;

   -----------------------------
   -- Is_Test_Fixture_Routine --
   -----------------------------

   function Is_Test_Fixture_Routine (Subp : Asis.Element) return Boolean is
      Params     : constant Parameter_Specification_List :=
        Parameter_Profile (Subp);

      Param_Type : Asis.Element;

      Dec_Elem, Def_Elem : Asis.Element;

   begin
      if not Is_Test_Routine (Subp) then
         return False;
      end if;

      Param_Type := Object_Declaration_View (Params (Params'First));

      if Definition_Kind (Param_Type) = An_Access_Definition then
         return False;
      end if;

      Param_Type :=
        Corresponding_Name_Declaration (Normalize_Reference (Param_Type));

      Dec_Elem := Param_Type;
      loop

         if
           To_String (Defining_Name_Image (First_Name (Dec_Elem))) =
           "Test_Case"
         then
            if Is_AUnit_Part (Enclosing_Compilation_Unit (Dec_Elem)) then
               return False;
            end if;
         end if;

         Def_Elem := Type_Declaration_View (Dec_Elem);

         if Definition_Kind (Def_Elem) = A_Private_Extension_Definition then

            Dec_Elem := Corresponding_Type_Declaration (Dec_Elem);
            Def_Elem := Type_Declaration_View (Dec_Elem);
         end if;

         if Type_Kind (Def_Elem) = A_Tagged_Record_Type_Definition then
            exit;
         end if;

         if Definition_Kind (Def_Elem) = A_Tagged_Private_Type_Definition then
            Dec_Elem := Corresponding_Type_Declaration (Dec_Elem);
            exit;
         end if;

         if
           Type_Kind (Type_Declaration_View (Dec_Elem)) /=
           A_Derived_Record_Extension_Definition
         then
            return False;
         end if;

         Dec_Elem := Corresponding_Parent_Subtype (Def_Elem);

      end loop;

      return True;
   end Is_Test_Fixture_Routine;

   -----------------------
   --  Is_Test_Routine  --
   -----------------------

   function Is_Test_Routine (Subp : Asis.Element) return Boolean is
      Subp_Name  : constant String :=
        To_String (Defining_Name_Image (First_Name (Subp)));
   begin
      if not Is_Test_Related (Subp) then
         return False;
      end if;

      --  Checking for predefined AUnit set up and tear down routines.
      if Subp_Name = "Set_Up" then
         return False;
      end if;

      if Subp_Name = "Set_Up_Case" then
         return False;
      end if;

      if Subp_Name = "Tear_Down" then
         return False;
      end if;

      if Subp_Name = "Tear_Down_Case" then
         return False;
      end if;

      return True;
   end Is_Test_Routine;

   -----------------------
   --  Is_Test_Related  --
   -----------------------

   function Is_Test_Related (Subp : Asis.Element) return Boolean is

      Params     : constant Parameter_Specification_List :=
        Parameter_Profile (Subp);

      Param_Type : Asis.Element;

   begin

      if Params'Length /= 1 then
         return False;
      end if;

      if Is_AUnit_Part (Enclosing_Compilation_Unit (Subp)) then
         return False;
      end if;

      Param_Type := Object_Declaration_View (Params (Params'First));

      if Definition_Kind (Param_Type) = An_Access_Definition then
         return False;
      end if;

      Param_Type :=
        Corresponding_Name_Declaration (Normalize_Reference (Param_Type));

      Param_Type := Root_Type_Declaration (Param_Type);

      if Is_Nil (Param_Type) then
         return False;
      end if;

      if not Is_AUnit_Part (Enclosing_Compilation_Unit (Param_Type)) then
         return False;
      end if;

      return True;

   end Is_Test_Related;

   ------------------------
   -- Nesting_Difference --
   ------------------------

   function Nesting_Difference
     (Nesting_1, Nesting_2 : String) return String
   is
      L : constant Integer := Integer'Min (Nesting_1'Length, Nesting_2'Length);
   begin

      if Nesting_1'Length > Nesting_2'Length then
         return Nesting_1 (Nesting_1'First + L + 1 .. Nesting_1'Last);
      else
         return Nesting_2 (Nesting_2'First + L + 1 .. Nesting_2'Last);
      end if;

   end Nesting_Difference;

   -------------------------------
   --  Parent_Type_Declaration  --
   -------------------------------

   function Parent_Type_Declaration
     (Type_Dec : Asis.Element) return Asis.Element
   is
      Dec_Elem : Asis.Element := Type_Dec;
      Def_Elem : Asis.Element;
   begin

      Def_Elem := Type_Declaration_View (Dec_Elem);

      if Definition_Kind (Def_Elem) = A_Private_Extension_Definition then

         Dec_Elem := Corresponding_Type_Declaration (Dec_Elem);
         Def_Elem := Type_Declaration_View (Dec_Elem);
      end if;

      Dec_Elem := Corresponding_Parent_Subtype (Def_Elem);

      return Dec_Elem;

   exception

      when Asis.Exceptions.ASIS_Inappropriate_Element =>
         return Asis.Nil_Element;

   end Parent_Type_Declaration;

   ----------------------
   --  Positive_Image  --
   ----------------------

   function Positive_Image (P : Positive) return String is
   begin
      return Trim (Positive'Image (P), Both);
   end Positive_Image;

   --------------------
   -- Process_Source --
   --------------------

   procedure Process_Source (The_Unit : Asis.Compilation_Unit) is
      Source_Name : String_Access;
      Apropriate_Source : Boolean := True;

      Data : Data_Holder;
   begin

      Source_Name :=
        new String'(Base_Name (To_String (Text_Name (The_Unit))));

      if Harness_Only then
         Report_Source (Source_Name.all);
      end if;

      Gather_Data (The_Unit, Data, Apropriate_Source);

      if Apropriate_Source then

         case Data.Data_Kind is

            when Instantination_Data =>

               Generate_Suite_Instance (Data);
               Set_Source_Status (Data.Test_Unit_File_Name.all, Processed);
               return;

            when others =>
               null;

         end case;

         if Data.Good_For_Suite then
            Generate_Suite (Data);
            null;
         end if;

         if not Data.Generic_Kind then
            if
              Substitution_Suite        and
              Data.Good_For_Suite and not
              Data.TR_List.Is_Empty
            then
               Gather_Liskiv_Data (Data);
               if not Data.LTR_List.Is_Empty then
                  Data.Good_For_Substitution  := True;

               else
                  Data.Good_For_Substitution  := False;
               end if;
            else
               Data.Good_For_Substitution  := False;
            end if;

            if Substitution_Suite and then Data.Good_For_Substitution  then
               Generate_Substitution_Suite_From_Tests (Data);
            end if;
         end if;

      end if;

      Data.Test_Types.Clear;
      Data.TR_List.Clear;
      Data.ITR_List.Clear;
      Data.LTR_List.Clear;
      Data.TC_List.Clear;

   end Process_Source;

   -----------------------
   --  Process_Sources  --
   -----------------------

   procedure Process_Sources is
      Source_Name : String_Access;
      Successful_Initialization : Boolean := True;
      The_Unit : Asis.Compilation_Unit;

      procedure Iterate_Sources (All_CU : Asis.Compilation_Unit_List);
      --  iterates through compilation units and checks if they are present in
      --  the source table, if so - processes them.

      procedure Iterate_Sources (All_CU : Asis.Compilation_Unit_List) is
         File_Name : String_Access;
      begin

         for J in All_CU'Range loop

            if Unit_Origin (All_CU (J)) = An_Application_Unit then
               File_Name :=
                 new String'(Base_Name (To_String (Text_Name (All_CU (J)))));

               if Source_Present (File_Name.all) and then
                 Get_Source_Status (File_Name.all) = Waiting
               then
                  Process_Source (All_CU (J));
               end if;

               Free (File_Name);
            end if;
         end loop;

      end Iterate_Sources;

   begin

      if SF_Table_Empty then
         if Harness_Only then
            Report_Err ("gnattest: no tests to generate suites for");
            raise Fatal_Error;
         else
            return;
         end if;
      end if;

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

      loop
         Source_Name := new String'(Next_Non_Processed_Source);
         exit when Source_Name.all = "";

         Successful_Initialization := Initialize_Context (Source_Name.all);

         if Successful_Initialization then

            The_Unit := Main_Unit_In_Current_Tree (The_Context);

            --  processing main unit
            Process_Source (The_Unit);

            --  processing others in same context
            Iterate_Sources
              (Asis.Compilation_Units.Compilation_Units (The_Context));

         end if;

         Source_Clean_Up;
         Context_Clean_Up;
         Free (Source_Name);
      end loop;

      Asis.Implementation.Finalize;

      Test_Runner_Generator;
      Project_Creator;
      if Harness_Only then
         if not Gnattest_Generated_Present then
            Generate_Common_File;
         end if;
      end if;

   end Process_Sources;

   -----------------------
   --  Project_Creator  --
   -----------------------

   procedure Project_Creator
   is
      Tmp : String_Access;
   begin
      Generate_Gnattest_Common_Prj;

      Create (Harness_Dir.all & "test_driver.gpr");

      if Tmp_Test_Prj /= null then
         S_Put (0, "with """                 &
                Base_Name (Tmp_Test_Prj.all) &
                """;");
         Put_New_Line;
      end if;

      if Harness_Only then
         S_Put (0, "with """     &
                  Source_Prj.all &
                  """;");
         Put_New_Line;
      end if;

      if Additional_Tests_Prj /= null then
         S_Put (0, "with """     &
                  Additional_Tests_Prj.all &
                  """;");
         Put_New_Line;
      end if;

      S_Put (0, "with ""gnattest_common.gpr"";");
      Put_New_Line;

      Put_New_Line;
      S_Put (0, "project Test_Driver is");
      Put_New_Line;
      Put_New_Line;
      S_Put
           (3,
            "for Origin_Project use """
            & (+Relative_Path
                 (Create (+Source_Prj.all),
                   Create (+Normalize_Pathname (Harness_Dir.all))))
            & """;");
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "for Target use Gnattest_Common'Target;");
      Put_New_Line;
      Put_New_Line;
      S_Put
        (3,
         "for Runtime (""Ada"") use Gnattest_Common'Runtime (""Ada"");");
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "for Languages use (""Ada"");");
      Put_New_Line;
      S_Put (3, "for Main use (""test_runner.adb"");");
      Put_New_Line;

      if Source_Prj.all = "" then

         Reset_Location_Iterator;
         S_Put (3, "for Source_Dirs use");
         Put_New_Line;
         S_Put (5, "(""" & Next_Source_Location & """");

         loop
            Tmp := new String'(Next_Source_Location);

            if Tmp.all = "" then
               if Harness_Only and then not Gnattest_Generated_Present then
                  S_Put (0, ",");
                  Put_New_Line;
                  S_Put (6, """common""");
               end if;
               S_Put (0, ");");
               Put_New_Line;
               exit;
            else
               S_Put (0, ",");
               Put_New_Line;
               S_Put (6, """" & Tmp.all & """");
               Put_New_Line;
            end if;

         end loop;

      else
         if Harness_Only and then not Gnattest_Generated_Present then
            S_Put (3, "for Source_Dirs use (""."", ""common"");");
            Put_New_Line;
         end if;

      end if;

      S_Put (3, "for Exec_Dir use ""."";");
      Put_New_Line;
      Put_New_Line;

      S_Put (3, "package Builder renames Gnattest_Common.Builder;");
      Put_New_Line;
      S_Put (3, "package Linker renames Gnattest_Common.Linker;");
      Put_New_Line;
      S_Put (3, "package Binder renames Gnattest_Common.Binder;");
      Put_New_Line;
      S_Put (3, "package Compiler renames Gnattest_Common.Compiler;");
      Put_New_Line;
      Put_New_Line;

      if IDE_Package_Present then
         S_Put
           (3,
            "package Ide renames " &
            Test_Prj_Prefix &
            Base_Name (Source_Prj.all, File_Extension (Source_Prj.all)) &
            ".Ide;");
         Put_New_Line;
         Put_New_Line;
      end if;

      if Make_Package_Present then
         S_Put
           (3,
            "package Make renames " &
            Test_Prj_Prefix &
            Base_Name (Source_Prj.all, File_Extension (Source_Prj.all)) &
            ".Make;");
         Put_New_Line;
         Put_New_Line;
      end if;

      if not Harness_Only then
         S_Put (3, "package GNATtest is");
         Put_New_Line;
         S_Put (6, "for GNATTest_Mapping_File use ""gnattest.xml"";");
         Put_New_Line;
         S_Put (3, "end GNATtest;");
         Put_New_Line;
         Put_New_Line;
      end if;

      S_Put (0, "end Test_Driver;");

      Close_File;

      Generate_Global_Config_Pragmas_File;
   end Project_Creator;

   -----------------------------
   --  Root_Type_Declaration  --
   -----------------------------

   function Root_Type_Declaration
     (Type_Dec : Asis.Element) return Asis.Element
   is
      Dec_Elem : Asis.Element := Type_Dec;
      Def_Elem : Asis.Element;
   begin

      loop

         Def_Elem := Type_Declaration_View (Dec_Elem);

         if Definition_Kind (Def_Elem) = A_Private_Extension_Definition then

            Dec_Elem := Corresponding_Type_Declaration (Dec_Elem);
            Def_Elem := Type_Declaration_View (Dec_Elem);
         end if;

         if Type_Kind (Def_Elem) = A_Tagged_Record_Type_Definition then
            return Dec_Elem;
         end if;

         if Definition_Kind (Def_Elem) = A_Tagged_Private_Type_Definition then
            Dec_Elem := Corresponding_Type_Declaration (Dec_Elem);
            return Dec_Elem;
         end if;

         Dec_Elem := Corresponding_Parent_Subtype (Def_Elem);

      end loop;

   exception
      when Asis.Exceptions.ASIS_Inappropriate_Element =>
         return Asis.Nil_Element;

   end Root_Type_Declaration;

   -----------------------
   --  Source_Clean_Up  --
   -----------------------

   procedure Source_Clean_Up is
      Success : Boolean;
   begin
      if Last_Context_Name = null then
         return;
      end if;

      Delete_File (Last_Context_Name.all & ".adt", Success);
      if not Success then
         Report_Std ("gnattest: cannot delete " &
                     Last_Context_Name.all & ".adt");
      end if;

      Delete_File (Last_Context_Name.all & ".ali", Success);
      if not Success then
         Report_Std ("gnattest: cannot delete " &
                     Last_Context_Name.all & ".ali");
      end if;

      Free (Last_Context_Name);
   end Source_Clean_Up;

   -----------------------------
   --  Test_Runner_Generator  --
   -----------------------------

   procedure Test_Runner_Generator is
      Iterator : List_Of_Strings.Cursor;
   begin
      if List_Of_Strings.Is_Empty (Suit_List) then
         Report_Std
           ("gnattest: no test skeletons generated because "
            & "no subprogram to test");
         Report_Std
           ("found in project " & Source_Prj.all, 10);
         Report_Std ("cannot create main suite and test runner", 10);
         raise Fatal_Error;
      end if;

      --  creating main suite spec
      Create (Harness_Dir.all & Unit_To_File_Name (Main_Suite_Name) & ".ads");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      Put_New_Line;

      S_Put (0, "with AUnit.Test_Suites; use AUnit.Test_Suites;");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "package " & Main_Suite_Name & " is");
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "function Suite return Access_Test_Suite;");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "end " & Main_Suite_Name & ";");
      Put_New_Line;
      S_Put (0, GT_Marker_End);
      Put_New_Line;
      Close_File;

      --  creating main suite body
      Create
        (Harness_Dir.all & Unit_To_File_Name (Main_Suite_Name) & ".adb");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      Put_New_Line;

      Iterator := List_Of_Strings.First (Suit_List);
      loop
         exit when Iterator = List_Of_Strings.No_Element;

         S_Put
           (0,
            "with " & List_Of_Strings.Element (Iterator) & ";");
         Put_New_Line;

         List_Of_Strings.Next (Iterator);
      end loop;

      Put_New_Line;
      S_Put (0, "package body " & Main_Suite_Name & " is");
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "Result : aliased AUnit.Test_Suites.Test_Suite;");
      Put_New_Line;
      Put_New_Line;
      S_Put
        (3,
         "function Suite return AUnit.Test_Suites." & "Access_Test_Suite is");
      Put_New_Line;
      S_Put (3, "begin");
      Put_New_Line;
      Put_New_Line;

      Iterator := List_Of_Strings.First (Suit_List);
      loop
         exit when Iterator = List_Of_Strings.No_Element;

         S_Put
           (6,
            "Add_Test (Result'Access, " &
            List_Of_Strings.Element (Iterator) &
            ".Suite);");
         Put_New_Line;

         List_Of_Strings.Next (Iterator);
      end loop;

      Put_New_Line;
      S_Put (6, "return Result'Access;");
      Put_New_Line;
      Put_New_Line;
      S_Put (3, "end Suite;");
      Put_New_Line;
      Put_New_Line;
      S_Put (0, "end " & Main_Suite_Name & ";");
      Put_New_Line;
      S_Put (0, GT_Marker_End);
      Put_New_Line;
      Close_File;

      --  creating test runner body
      Create
        (Harness_Dir.all & Unit_To_File_Name (Test_Runner_Name) & ".adb");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      Put_New_Line;

      S_Put (0, "with AUnit.Reporter." & Reporter_Name.all & ";");
      Put_New_Line;
      S_Put (0, "with AUnit.Run;");
      Put_New_Line;
      S_Put (0, "with AUnit.Options; use AUnit.Options;");
      Put_New_Line;
      S_Put (0, "with " & Main_Suite_Name & "; use " & Main_Suite_Name & ";");
      Put_New_Line;
      Put_New_Line;
      if not No_Command_Line then
         S_Put (0, "with AUnit; use AUnit;");
         Put_New_Line;
         S_Put (0, "with Ada.Command_Line;");
         Put_New_Line;
      end if;
      if not No_Command_Line then
         S_Put (0, "with GNAT.Command_Line; use GNAT.Command_Line;");
         Put_New_Line;
         Put_New_Line;
         if not Harness_Only then
            S_Put (0, "with Gnattest_Generated;");
            Put_New_Line;
            Put_New_Line;
         end if;
      end if;
      S_Put (0, "procedure " & Test_Runner_Name & " is");
      Put_New_Line;
      if No_Command_Line then
         S_Put (3, "procedure Runner is new AUnit.Run.Test_Runner (Suite);");
      else
         S_Put
           (3,
            "function Runner is new "
            & "AUnit.Run.Test_Runner_With_Status (Suite);");
         Put_New_Line;
         S_Put (3, "Exit_Status : AUnit.Status;");
         Put_New_Line;
         if Add_Exit_Status then
            S_Put (3, "Use_Exit_Status : Boolean := True;");
         else
            S_Put (3, "Use_Exit_Status : Boolean := False;");
         end if;
      end if;
      Put_New_Line;
      S_Put
        (3,
         "Reporter : AUnit.Reporter."
         & Reporter_Name.all
         & "."
         & Reporter_Name.all
         & "_Reporter;");
      Put_New_Line;
      S_Put (3, "GT_Options : AUnit_Options := Default_Options;");
      Put_New_Line;
      S_Put (0, "begin");
      Put_New_Line;
      Put_New_Line;
      if Show_Passed_Tests then
         S_Put (3, "GT_Options.Report_Successes := True;");
      else
         S_Put (3, "GT_Options.Report_Successes := False;");
      end if;
      Put_New_Line;
      if Show_Test_Duration then
         S_Put (3, "GT_Options.Test_Case_Timer := True;");
      end if;
      Put_New_Line;
      if not No_Command_Line then
         S_Put (3, "begin");
         Put_New_Line;
         S_Put (6, "Initialize_Option_Scan;");
         Put_New_Line;
         S_Put (6, "loop");
         Put_New_Line;
         S_Put (9, "case GNAT.Command_Line.Getopt");
         Put_New_Line;
         if Harness_Only then
            --  No point in --skeleton-default in --harness-only mode.
            S_Put
              (11, "(""-passed-tests= -exit-status="")");
         else
            S_Put
              (11, "(""-skeleton-default= -passed-tests= -exit-status="")");
         end if;
         Put_New_Line;
         S_Put (9, "is");
         Put_New_Line;
         S_Put (12, "when ASCII.NUL =>");
         Put_New_Line;
         S_Put (15, "exit;");
         Put_New_Line;
         S_Put (12, "when '-' =>");
         Put_New_Line;
         --  --skeleton-default
         if not Harness_Only then
            S_Put (15, "if Full_Switch = ""-skeleton-default"" then");
            Put_New_Line;
            S_Put (18, "if Parameter = ""pass"" then");
            Put_New_Line;
            S_Put (21, "Gnattest_Generated.Default_Assert_Value := True;");
            Put_New_Line;
            S_Put (18, "elsif Parameter = ""fail"" then");
            Put_New_Line;
            S_Put (21, "Gnattest_Generated.Default_Assert_Value := False;");
            Put_New_Line;
            S_Put (18, "end if;");
            Put_New_Line;
            S_Put (15, "end if;");
            Put_New_Line;
         end if;
         --  --passed-tests
         S_Put (15, "if Full_Switch = ""-passed-tests"" then");
         Put_New_Line;
         S_Put (18, "if Parameter = ""show"" then");
         Put_New_Line;
         S_Put (21, "GT_Options.Report_Successes := True;");
         Put_New_Line;
         S_Put (18, "elsif Parameter = ""hide"" then");
         Put_New_Line;
         S_Put (21, "GT_Options.Report_Successes := False;");
         Put_New_Line;
         S_Put (18, "end if;");
         Put_New_Line;
         S_Put (15, "end if;");
         Put_New_Line;
         --  --exit-status
         S_Put (15, "if Full_Switch = ""-exit-status"" then");
         Put_New_Line;
         S_Put (18, "if Parameter = ""on"" then");
         Put_New_Line;
         S_Put (21, "Use_Exit_Status := True;");
         Put_New_Line;
         S_Put (18, "elsif Parameter = ""off"" then");
         Put_New_Line;
         S_Put (21, "Use_Exit_Status := False;");
         Put_New_Line;
         S_Put (18, "end if;");
         Put_New_Line;
         S_Put (15, "end if;");
         Put_New_Line;
         S_Put (12, "when others => null;");
         Put_New_Line;
         S_Put (9, "end case;");
         Put_New_Line;
         S_Put (6, "end loop;");
         Put_New_Line;
         S_Put (3, "exception");
         Put_New_Line;
         S_Put (6, "when GNAT.Command_Line.Invalid_Switch => null;");
         Put_New_Line;
         S_Put (3, "end;");
         Put_New_Line;
         Put_New_Line;
      end if;
      if No_Command_Line then
         S_Put (3, "Runner (Reporter, GT_Options);");
      else
         S_Put (3, "Exit_Status := Runner (Reporter, GT_Options);");
         Put_New_Line;
         S_Put
           (3,
            "if Use_Exit_Status and then Exit_Status = AUnit.Failure then");
         Put_New_Line;
         S_Put
           (6,
            "Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);");
         Put_New_Line;
         S_Put (3, "end if;");
      end if;
      Put_New_Line;
      S_Put (0, "end " & Test_Runner_Name & ";");
      Put_New_Line;
      S_Put (0, GT_Marker_End);
      Put_New_Line;
      Close_File;

   end Test_Runner_Generator;

   -----------------------
   -- Type_Test_Package --
   -----------------------

   function Type_Test_Package (Elem : Asis.Element) return String
   is
      Type_Nesting : constant String := Get_Nesting (Elem);
      Package_Name : constant String :=
        To_String (Unit_Full_Name (Enclosing_Compilation_Unit (Elem)));
   begin
      if Type_Nesting = Package_Name then
         return
           Package_Name & "." & Type_Name (Elem) &
           Test_Data_Unit_Name_Suff & "." &
           Type_Name (Elem) & Test_Unit_Name_Suff;
      end if;

      return
        Package_Name & "." &
        Test_Data_Unit_Name & "." &
        Test_Unit_Name & "." &
        Nesting_Difference
        (Type_Nesting,
         Package_Name) &
        "." &
        Type_Name (Elem) &
        Test_Data_Unit_Name_Suff &
        "." &
        Type_Name (Elem) &
        Test_Unit_Name_Suff;
   end Type_Test_Package;

end GNATtest.Harness.Generator;