------------------------------------------------------------------------------
--                                                                          --
--                           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-2013, 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_2005;

with Ada.Containers.Indefinite_Ordered_Sets;

with Ada.Text_IO;                use Ada.Text_IO;
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.Statements;            use Asis.Statements;
with Asis.Text;                  use Asis.Text;

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

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

package body GNATtest.Harness.Generator is

   use List_Of_Strings;

   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

   ------------------------
   --  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_Case (Type_Decl : Asis.Element) return Boolean;
   --  Indicates if given type is a test_case type of AUnit framework.

   function Is_Implemented_Test (Subp : Asis.Element) return Boolean;
   --  Returns False if the first statement in test body is Assert with first
   --  atual parameter being False. Otherwise returns True.

   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.

   -----------------
   -- 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);
   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)
                  & ": additional test 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) is
      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;

      function Type_Name (Elem : Asis.Element) return String;

      function Type_Test_Package (Elem : Asis.Element) return String;

      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;

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

      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;

   begin

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

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      New_Line (Output_File);

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

      Close (Output_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 (Output_File,
              Out_File,
              Harness_Dir.all                    &
              Unit_To_File_Name (New_Unit_Name) &
              ".adb");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      New_Line (Output_File);

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

      --  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) & ";");
         New_Line (Output_File);
         Include_Sets.Next (Include_Cur);
      end loop;

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

      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");
         New_Line (Output_File);

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

         New_Line (Output_File);
      end loop;

      New_Line (Output_File);

      --  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");
               New_Line (Output_File);
               S_Put (5,
                      "(T : in out " &
                      PUnit_Im.all   &
                      "."            &
                      Type_Im.all    &
                      ");");
               New_Line (Output_File);

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

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

      --  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;");
            New_Line (Output_File);
         end loop;

      end loop;

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

      --  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");
            New_Line (Output_File);
            S_Put (8,
                   "(Test_Method_"                &
                   Positive_Image (K)             &
                   "_"                            &
                   Trim (Integer'Image (I), Both) &
                   ", Runner_"                    &
                   Positive_Image (K)             &
                   ".Test_Method);");
            New_Line (Output_File);
         end loop;
      end loop;

      New_Line (Output_File);
      S_Put (3, "begin");
      New_Line (Output_File);
      New_Line (Output_File);

      --  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");
            New_Line (Output_File);
            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)         &
               ",");
            New_Line (Output_File);
            S_Put (9,
                   """"
                   & Data.LTR_List.Element (K).Tested_Sloc.all
                   & """,");
            New_Line (Output_File);
            S_Put (9,
                   "Convert ("                                &
                   PUnit_Im.all                               &
                   "."                                        &
                   Data.LTR_List.Element (K).TR_Text_Name.all &
                   "'Access));");
            New_Line (Output_File);

            Free (PUnit_Im);

         end loop;

      end loop;

      New_Line (Output_File);

      --  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,
               "Result.Add_Test ("                              &
               Test_Case_Prefix                                 &
               Positive_Image (Current_TT_Number)               &
               "_"                                              &
               Data.LTR_List.Element (K).TR_Text_Name.all       &
               "_"                                              &
               Trim (Integer'Image (Depth), Both)               &
               "'Access);");
            New_Line (Output_File);

         end loop;

      end loop;

      New_Line (Output_File);
      S_Put (6, "return Result'Access;");
      New_Line (Output_File);
      New_Line (Output_File);
      S_Put (3, "end Suite;");
      New_Line (Output_File);
      New_Line (Output_File);
      S_Put (0, "end " & New_Unit_Name & ";");
      New_Line (Output_File);
      S_Put (0, GT_Marker_End);
      New_Line (Output_File);
      Close (Output_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 (Output_File,
              Out_File,
              Harness_Dir.all                    &
              Unit_To_File_Name (New_Unit_Name) &
              ".ads");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      New_Line (Output_File);

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

      Close (Output_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 (Output_File,
              Out_File,
              Harness_Dir.all                    &
              Unit_To_File_Name (New_Unit_Name) &
              ".adb");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      New_Line (Output_File);

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

      --  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) & ";");
         New_Line (Output_File);
         Include_Sets.Next (Include_Cur);
      end loop;

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

      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");
         New_Line (Output_File);

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

         New_Line (Output_File);
      end loop;

      New_Line (Output_File);

      --  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");
            New_Line (Output_File);
            S_Put (5,
                   "(T : in out " &
                   PUnit_Im.all   &
                   "."            &
                   Type_Im.all    &
                   ");");
            New_Line (Output_File);

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

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

      --  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;");
            New_Line (Output_File);
         end loop;

      end loop;

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

      --  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");
            New_Line (Output_File);
            S_Put (8,
                   "(Test_Method_"                &
                   Positive_Image (K)             &
                   "_"                            &
                   Trim (Integer'Image (I), Both) &
                   ", Runner_"                    &
                   Positive_Image (K)             &
                   ".Test_Method);");
            New_Line (Output_File);
         end loop;
      end loop;

      New_Line (Output_File);
      S_Put (3, "begin");
      New_Line (Output_File);
      New_Line (Output_File);

      --  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");
            New_Line (Output_File);
            S_Put
              (8,
               "("                                        &
               Test_Case_Prefix                           &
               Positive_Image (Type_Number)               &
               "_"                                        &
               Data.LTR_List.Element (K).TR_Text_Name.all &
               "_"                                        &
               Trim (Integer'Image (Depth), Both)         &
               ",");
            New_Line (Output_File);
            S_Put (9,
                   """"
                   & Data.LTR_List.Element (K).Tested_Sloc.all
                   & """,");
            New_Line (Output_File);
            S_Put (9,
                   "Convert ("                                &
                   PUnit_Im.all                               &
                   "."                                        &
                   Data.LTR_List.Element (K).TR_Text_Name.all &
                   "'Access));");
            New_Line (Output_File);

            Free (PUnit_Im);

         end loop;

      end loop;

      New_Line (Output_File);

      --  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,
               "Result.Add_Test ("                        &
               Test_Case_Prefix                           &
               Positive_Image (Type_Number)               &
               "_"                                        &
               Data.LTR_List.Element (K).TR_Text_Name.all &
               "_"                                        &
               Trim (Integer'Image (Depth), Both)         &
               "'Access);");
            New_Line (Output_File);

         end loop;

      end loop;

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

      Close (Output_File);

      List_Of_Strings.Append (Suit_List, New_Unit_Name);

   end Generate_Substitution_Suite_From_Tests;

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

   procedure Generate_Suite (Data : Data_Holder) is
      New_Unit_Name : String_Access;

      Current_Type : Test_Type_Info;
   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 (Output_File,
              Out_File,
              Harness_Dir.all                        &
              Unit_To_File_Name (New_Unit_Name.all) &
              ".ads");

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      New_Line (Output_File);

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

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

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

      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");
            New_Line (Output_File);

            S_Put (5,
                   "("                           &
                   Data.Test_Unit_Full_Name.all  &
                   "."                           &
                   Data.Test_Types.Element (I).Test_Type_Name.all &
                   ");");
            New_Line (Output_File);
            New_Line (Output_File);
         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 :=");
            New_Line (Output_File);
            S_Put (5,
                   Data.TR_List.Element (K).TR_Text_Name.all &
                   "'Access;");
            New_Line (Output_File);

         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 :=");
            New_Line (Output_File);
            S_Put (5,
                   Data.ITR_List.Element (K).TR_Text_Name.all &
                   "'Access;");
            New_Line (Output_File);

         end loop;

         New_Line (Output_File);

      end if;

      S_Put (0, "end " & New_Unit_Name.all & ";");
      New_Line (Output_File);
      S_Put (0, GT_Marker_End);
      New_Line (Output_File);
      Close (Output_File);

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

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      New_Line (Output_File);

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

      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");
            New_Line (Output_File);

            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;

            New_Line (Output_File);
            New_Line (Output_File);
         end loop;

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

         New_Line (Output_File);
         New_Line (Output_File);

      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;

         New_Line (Output_File);
      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;

         New_Line (Output_File);

      end loop;

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

      --  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                &
                   " :=");
            New_Line (Output_File);
            S_Put (8,
                   "Runner_"                                                &
                   Positive_Image (Data.TR_List.Element (K).Test_Type_Numb) &
                   ".Create");
            New_Line (Output_File);
            S_Put (10,
                   " (Instance_Name &");
            New_Line (Output_File);
            S_Put (11,
                   " "" : "                                  &
                   Data.TR_List.Element (K).TR_Text_Name.all &
                   """,");
            New_Line (Output_File);
            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");
            New_Line (Output_File);
            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                &
                   ",");
            New_Line (Output_File);
            S_Put (9,
                   """"
                   & Data.TR_List.Element (K).Tested_Sloc.all
                   & """,");
            New_Line (Output_File);
            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;

         New_Line (Output_File);

      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                &
                   " :=");
            New_Line (Output_File);
            S_Put (8,
                   "Runner_"                                                 &
                   Positive_Image (Data.ITR_List.Element (K).Test_Type_Numb) &
                   ".Create");
            New_Line (Output_File);
            S_Put (10, "(Instance_Name &");
            New_Line (Output_File);
            S_Put (11, """ (inherited from " &
                   Data.ITR_List.Element (K).TR_Rarent_Unit_Name.all    &
                   ") : "                                               &
                   Data.ITR_List.Element (K).TR_Text_Name.all           &
                   """,");
            New_Line (Output_File);
            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");
            New_Line (Output_File);
            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                &
                   ",");
            New_Line (Output_File);

            S_Put (9,
                   """"
                   & Data.ITR_List.Element (K).Tested_Sloc.all
                   & """,");
            New_Line (Output_File);
            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;

         New_Line (Output_File);

      end loop;

      New_Line (Output_File);

      --  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,
                   "Result.Add_Test ("                                       &
                   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,
                   "Result.Add_Test ("                                       &
                   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;

         New_Line (Output_File);

      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,
                   "Result.Add_Test ("                                       &
                   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,
                   "Result.Add_Test ("                                       &
                   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;

         New_Line (Output_File);

      end loop;

      New_Line (Output_File);

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

      if Data.Generic_Kind then
         S_Put (6, "return Result;");
      else
         S_Put (6, "return Result'Access;");
      end if;
      New_Line (Output_File);
      New_Line (Output_File);
      S_Put (3, "end Suite;");
      New_Line (Output_File);
      New_Line (Output_File);
      S_Put (0, "end " & New_Unit_Name.all & ";");
      New_Line (Output_File);
      S_Put (0, GT_Marker_End);
      New_Line (Output_File);
      Close (Output_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 (Output_File,
              Out_File,
              Harness_Dir.all                    &
              Unit_To_File_Name (New_Unit_Name) &
              ".ads");

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

      Close (Output_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 (Output_File,
              Out_File,
              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   &
             ";");
      New_Line (Output_File);
      New_Line (Output_File);
      S_Put (0, "package " & New_Substitution_Unit_Name & " is new");
      New_Line (Output_File);
      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 (Output_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");

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

   function Is_Implemented_Test (Subp : Asis.Element) return Boolean
   is
      Body_Decl : Asis.Declaration;
   begin

      case Declaration_Kind (Corresponding_Body (Subp)) is
         when A_Procedure_Body_Stub =>
            Body_Decl := Corresponding_Subunit (Corresponding_Body (Subp));
         when A_Procedure_Body_Declaration =>
            Body_Decl := Corresponding_Body (Subp);
         when others =>
            return True;
      end case;

      declare
         B_Stat     : constant Asis.Statement_List :=
           Body_Statements (Body_Decl);
         First_Stat : constant Asis.Statement      :=
           B_Stat (B_Stat'First);
      begin
         if Statement_Kind (First_Stat) = A_Procedure_Call_Statement then
            if
               Expression_Kind (Called_Name (First_Stat)) = An_Identifier
            then
               if Name_Image (Called_Name (First_Stat)) =  "Assert" then
                  declare
                     Params      : constant Asis.Association_List :=
                       Call_Statement_Parameters (First_Stat);
                     First_Param : constant Asis.Association      :=
                       Params (Params'First);
                  begin
                     if Params'Length = 0 then
                        return True;
                     end if;

                     if
                       To_Lower (Trim (To_String (Element_Image
                         (Actual_Parameter (First_Param))), Both)) = "false"
                     then
                        return False;
                     end if;
                  end;
               end if;
            end if;
         end if;
      end;
      return True;
   end Is_Implemented_Test;

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

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

      Params     : constant Parameter_Specification_List :=
        Parameter_Profile (Subp);

      Subp_Name  : constant String :=
        To_String (Defining_Name_Image (First_Name (Subp)));

      Param_Type : Asis.Element;

      Dec_Elem, Def_Elem : 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));

      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;

      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;

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

   ------------------------
   -- 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
      Create (Output_File,
              Out_File,
              Harness_Dir.all & "test_driver.gpr");

      S_Put (0, "with ""aunit"";");
      New_Line (Output_File);

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

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

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

      New_Line (Output_File);
      S_Put (0, "project Test_Driver is");
      New_Line (Output_File);
      New_Line (Output_File);
      S_Put (3, "for Languages use (""Ada"");");
      New_Line (Output_File);
      S_Put (3, "for Main use (""test_runner.adb"");");
      New_Line (Output_File);

      if Source_Prj.all = "" then

         Reset_Location_Iterator;
         S_Put (3, "for Source_Dirs use");
         New_Line (Output_File);
         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, ",");
                  New_Line (Output_File);
                  S_Put (6, """common""");
               end if;
               S_Put (0, ");");
               New_Line (Output_File);
               exit;
            else
               S_Put (0, ",");
               New_Line (Output_File);
               S_Put (6, """" & Tmp.all & """");
               New_Line (Output_File);
            end if;

         end loop;

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

      end if;

      S_Put (3, "for Exec_Dir use ""."";");
      New_Line (Output_File);
      New_Line (Output_File);

      if Suppress_Contacts then
         S_Put (3, "package Builder is");
         New_Line (Output_File);
         S_Put (6, "for Global_Configuration_Pragmas use ""suppress.adc"";");
         New_Line (Output_File);
         S_Put (3, "end Builder;");
         New_Line (Output_File);
         New_Line (Output_File);
      end if;

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

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

      S_Put (3, "package Compiler is");
      New_Line (Output_File);
      S_Put (6, "for Default_Switches (""ada"") use");
      New_Line (Output_File);
      S_Put
        (8,
         "(""-g"", ""-O1"", " &
         """-gnatyM0"", ""-gnata""");
      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, ");");
      New_Line (Output_File);
      S_Put (3, "end Compiler;");
      New_Line (Output_File);
      New_Line (Output_File);

      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;");
         New_Line (Output_File);
         New_Line (Output_File);
      end if;

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

      S_Put (0, "end Test_Driver;");

      Close (Output_File);

      if Suppress_Contacts then
         Create (Output_File,
                 Out_File,
                 Harness_Dir.all & "suppress.adc");
         S_Put (0, "pragma Check_Policy (Precondition, Off);");
         New_Line (Output_File);
         S_Put (0, "pragma Check_Policy (Postcondition, Off);");
         New_Line (Output_File);
         Close (Output_File);
      end if;
   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 units with non-abstract test types");
         Report_Std ("cannot create main suite and test runner", 10);
         raise Fatal_Error;
      end if;

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

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      New_Line (Output_File);

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

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

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      New_Line (Output_File);

      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) & ";");
         New_Line (Output_File);

         List_Of_Strings.Next (Iterator);
      end loop;

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

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

         S_Put
           (6,
            "Result.Add_Test (" &
            List_Of_Strings.Element (Iterator) &
            ".Suite);");
         New_Line (Output_File);

         List_Of_Strings.Next (Iterator);
      end loop;

      New_Line (Output_File);
      S_Put (6, "return Result'Access;");
      New_Line (Output_File);
      New_Line (Output_File);
      S_Put (3, "end Suite;");
      New_Line (Output_File);
      New_Line (Output_File);
      S_Put (0, "end " & Main_Suite_Name & ";");
      New_Line (Output_File);
      S_Put (0, GT_Marker_End);
      New_Line (Output_File);
      Close (Output_File);

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

      Put_Harness_Header;
      S_Put (0, GT_Marker_Begin);
      New_Line (Output_File);

      S_Put (0, "with AUnit.Reporter.GNATtest;");
      New_Line (Output_File);
      S_Put (0, "with AUnit.Run;");
      New_Line (Output_File);
      S_Put (0, "with AUnit.Options; use AUnit.Options;");
      New_Line (Output_File);
      S_Put (0, "with " & Main_Suite_Name & "; use " & Main_Suite_Name & ";");
      New_Line (Output_File);
      New_Line (Output_File);
      if not Harness_Only and then not No_Command_Line then
         S_Put (0, "with GNAT.Command_Line; use GNAT.Command_Line;");
         New_Line (Output_File);
         New_Line (Output_File);
         S_Put (0, "with Gnattest_Generated;");
         New_Line (Output_File);
         New_Line (Output_File);
      end if;
      S_Put (0, "procedure " & Test_Runner_Name & " is");
      New_Line (Output_File);
      S_Put (3, "procedure Runner is new AUnit.Run.Test_Runner (Suite);");
      New_Line (Output_File);
      S_Put (3, "Reporter : AUnit.Reporter.GNATtest.GNATtest_Reporter;");
      New_Line (Output_File);
      S_Put (3, "GT_Options : AUnit_Options := Default_Options;");
      New_Line (Output_File);
      S_Put (0, "begin");
      New_Line (Output_File);
      New_Line (Output_File);
      if Show_Passed_Tests then
         S_Put (3, "GT_Options.Report_Successes := True;");
      else
         S_Put (3, "GT_Options.Report_Successes := False;");
      end if;
      New_Line (Output_File);
      New_Line (Output_File);
      if not Harness_Only and then not No_Command_Line then
         S_Put (3, "begin");
         New_Line (Output_File);
         S_Put (6, "Initialize_Option_Scan;");
         New_Line (Output_File);
         S_Put (6, "loop");
         New_Line (Output_File);
         S_Put (9,
                "case GNAT.Command_Line.Getopt (""-skeleton-default= "
                & "-passed-tests="") is");
         New_Line (Output_File);
         S_Put (12, "when ASCII.NUL =>");
         New_Line (Output_File);
         S_Put (15, "exit;");
         New_Line (Output_File);
         S_Put (12, "when '-' =>");
         New_Line (Output_File);
         S_Put (15, "if Full_Switch = ""-skeleton-default"" then");
         New_Line (Output_File);
         S_Put (18, "if Parameter = ""pass"" then");
         New_Line (Output_File);
         S_Put (21, "Gnattest_Generated.Default_Assert_Value := True;");
         New_Line (Output_File);
         S_Put (18, "elsif Parameter = ""fail"" then");
         New_Line (Output_File);
         S_Put (21, "Gnattest_Generated.Default_Assert_Value := False;");
         New_Line (Output_File);
         S_Put (18, "end if;");
         New_Line (Output_File);
         S_Put (15, "end if;");
         New_Line (Output_File);
         S_Put (15, "if Full_Switch = ""-passed-tests"" then");
         New_Line (Output_File);
         S_Put (18, "if Parameter = ""show"" then");
         New_Line (Output_File);
         S_Put (21, "GT_Options.Report_Successes := True;");
         New_Line (Output_File);
         S_Put (18, "elsif Parameter = ""hide"" then");
         New_Line (Output_File);
         S_Put (21, "GT_Options.Report_Successes := False;");
         New_Line (Output_File);
         S_Put (18, "end if;");
         New_Line (Output_File);
         S_Put (15, "end if;");
         New_Line (Output_File);
         S_Put (12, "when others => null;");
         New_Line (Output_File);
         S_Put (9, "end case;");
         New_Line (Output_File);
         S_Put (6, "end loop;");
         New_Line (Output_File);
         S_Put (3, "exception");
         New_Line (Output_File);
         S_Put (6, "when GNAT.Command_Line.Invalid_Switch => null;");
         New_Line (Output_File);
         S_Put (3, "end;");
         New_Line (Output_File);
         New_Line (Output_File);
      end if;
      S_Put (3, "Runner (Reporter, GT_Options);");
      New_Line (Output_File);
      S_Put (0, "end " & Test_Runner_Name & ";");
      New_Line (Output_File);
      S_Put (0, GT_Marker_End);
      New_Line (Output_File);
      Close (Output_File);

   end Test_Runner_Generator;

end GNATtest.Harness.Generator;