------------------------------------------------------------------------------
--                                                                          --
--                          AUNITGLUE COMPONENTS                            --
--                                                                          --
--                  A U N I T G L U E . G E N E R A T O R                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2008-2011, AdaCore                     --
--                                                                          --
-- AUNITGLUE 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.  AUNITGLUE  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.,                                      --
--                                                                          --
-- AUNITGLUE is maintained by AdaCore (http://www.adacore.com).             --
--                                                                          --
------------------------------------------------------------------------------
pragma Ada_2005;

with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Ordered_Sets;
with Ada.Containers.Indefinite_Vectors;

with GNAT.OS_Lib;                use GNAT.OS_Lib;

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;                       use Asis;
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 AUnitGlue.Source_Table;     use AUnitGlue.Source_Table;
with AUnitGlue.Common;           use AUnitGlue.Common;
with AUnitGlue.Options;          use AUnitGlue.Options;
with AUnitGlue.Environment;      use AUnitGlue.Environment;

package body AUnitGlue.Generator is

   --------------------
   --  Data Storing  --
   --------------------

   type Test_Type_Info is record
      Test_Type             : Asis.Declaration := Asis.Nil_Element;
      Test_Type_Name        : String_Access := null;
      Good_For_Liskov       : Boolean := False;

      Max_Inheritance_Depth : Natural := 0;
      --  Inheritance depth of a test routine is a number of packages
      --  in the hierarchy of the test type between the original
      --  declaration and the current overriding declaration plus one.
      --  So if the test routine is overrifen right in the next test
      --  package, it's inheritance depth will be 1.
      --  Max_Inheritance_Depth indicates the maximum of all inheritance
      --  depths of the test routines in the LTR_List that are primitives
      --  of the given test type..

      Nesting : String_Access;
   end record;

   package TT_Info is new
     Ada.Containers.Indefinite_Vectors (Positive, Test_Type_Info);
   use TT_Info;

   type Test_Routine_Info is tagged record
      TR_Declaration : Asis.Declaration;
      TR_Text_Name   : String_Access;
      Test_Type_Numb : Positive;
      Nesting        : String_Access;
   end record;

   package TR_Info is new
     Ada.Containers.Indefinite_Vectors (Positive, Test_Routine_Info);

   use TR_Info;

   type Test_Routine_Info_Enhanced is new Test_Routine_Info with record
      TR_Parent_Unit_Decl : Asis.Compilation_Unit;
      TR_Rarent_Unit_Name : String_Access;
   end record;

   package TR_Info_Enhanced is new
     Ada.Containers.Indefinite_Vectors (Positive, Test_Routine_Info_Enhanced);

   use TR_Info_Enhanced;

   type Data_Kind_Type is
     (Declaration_Data,
      Instantination_Data);

   type Data_Holder (Data_Kind : Data_Kind_Type := Declaration_Data) is record

      Test_Unit : Asis.Compilation_Unit;
      --  The CU under consideration.

      Test_Unit_Full_Name : String_Access := null;
      --  Fully expanded Ada name of the CU under consideation.

      Test_Unit_File_Name : String_Access := null;
      --  Name of file containing the CU under consideration.

      case Data_Kind is
         --  Indicates which data storing structures are used, determines the
         --  way of suite generation.

         when Declaration_Data =>

            Test_Types : TT_Info.Vector;
            --  List of test types.

            TR_List  : TR_Info.Vector;
            --  List of test routines declared in the test package.

            ITR_List : TR_Info_Enhanced.Vector;
            --  List of test routines inherited from packages declaring
            --  predecessing test types.

            LTR_List : TR_Info_Enhanced.Vector;
            --  List of test routines overriden in current package.

            --  Flags:
            Generic_Kind         : Boolean;
            --  On, when the given package is generic.

            Good_For_Suite       : Boolean := False;
            --  The suite should be generated.

            Good_For_Liskov      : Boolean := False;
            --  Liskov suite should be generated.

         when Instantination_Data =>

            Gen_Unit : Asis.Compilation_Unit := Asis.Nil_Compilation_Unit;
            --  Generic CU that is instatinated into the given one.

            Gen_Unit_Full_Name : String_Access := null;
            --  Fully expanded Ada name of the generic CU.

            Gen_Unit_File_Name : String_Access := null;
            --  Name of file containing the generic CU.

      end case;

   end record;

   package String_List is new
     Ada.Containers.Indefinite_Doubly_Linked_Lists (String);

   use String_List;

   package Ancestors is new
     Ada.Containers.Indefinite_Vectors (Positive, String);
   use Ancestors;

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

   Good_For_Liskov_Inst : String_List.List;
   --  Storing the names of generic test packages, that should have a liskov
   --  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

   Liskov_Suite_Name          : constant String := "Suite_Liskov";
   --  Suffixless name of the unit containing liskov suite

   Generic_Liskov_Suite_Name  : constant String := "Gen_Suite_Liskov";
   --  Suffixless name of the unit containing a generic liskov suite

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

   Liskov_Instant_Suite_Name  : constant String := "Liskov_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 := "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

   Output_File : File_Type;

   -------------------------
   --  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 Inheritance_Depth
     (Type_Decl    : Asis.Element;
      Target_Unit  : Asis.Compilation_Unit)
      return Natural;
   --  Returns the number of packages between the one containing Type_Decl
   --  and Target_Unit, that contain intermidiate test type extensions.
   --  See commnets to Data_Holder type.

   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_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_Suite (Data : Data_Holder);
   --  Creates a test suite (generic o common) for both the directly declared
   --  tests and inherited ones.

   procedure Generate_Liskov_Suite (Data : Data_Holder);
   --  Creates a liskov 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 Test_Runner_Generator;
   --  Generates Main_Sute and Test_Runner

   procedure Project_Creator;
   --  Generates a simple project file for the test driver.

   function Unit_To_File_Name (Old : String) return String;
   --  Replaces dots with "-" and lowers the case of the letters.

   procedure S_Put (Span : Natural; Text : String);
   --  Adds Span number spaces before the Text and prints it to Output_File

   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;
      Unit_Im         : String_Access;

      Type_Number : Positive;
      Depth       : Natural;

      Parent_Unit :          Asis.Compilation_Unit;
      Arg_Init    : constant Asis.Compilation_Unit :=
        Data.Test_Unit;

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

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

               if Is_Equal (Enclosing_Compilation_Unit (Overridden_Subp),
                            Arg_Init)
               then
                  Parent_Unit :=
                    Enclosing_Compilation_Unit
                      (Corresponding_Generic_Package
                           (Enclosing_Element
                                (Overridden_Subp)));

               else
                  Parent_Unit :=
                    Enclosing_Compilation_Unit (Overridden_Subp);
               end if;

               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;

               Data.LTR_List.Append (Test_Routine);

               Depth :=
                 Inheritance_Depth
                   (Data.Test_Types.Element (Type_Number).Test_Type,
                    Test_Routine.TR_Parent_Unit_Decl);

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

   procedure Generate_Liskov_Suite (Data : Data_Holder) is

      New_Unit_Name : constant String :=
        Data.Test_Unit_Full_Name.all & "." & Liskov_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,
              Output_Dir.all                    &
              Unit_To_File_Name (New_Unit_Name) &
              ".ads");

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

      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,
              Output_Dir.all                    &
              Unit_To_File_Name (New_Unit_Name) &
              ".adb");

      S_Put (0, "with AUnit.Test_Caller;");
      New_Line (Output_File);
      S_Put (0, "with Ada.Unchecked_Conversion;");
      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,
                "(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,
            Data.LTR_List.Element (K).TR_Parent_Unit_Decl)
         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 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,
            Data.LTR_List.Element (K).TR_Parent_Unit_Decl)
         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.Test_Unit_Full_Name.all               &
                   " as "                                     &
                   PUnit_Im.all                               &
                   " (overridden) : "                         &
                   Data.LTR_List.Element (K).TR_Text_Name.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,
            Data.LTR_List.Element (K).TR_Parent_Unit_Decl)
         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 & ";");

      Close (Output_File);

      String_List.Append (Suit_List, New_Unit_Name);

   end Generate_Liskov_Suite;

   ----------------------
   --  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,
              Output_Dir.all                        &
              Unit_To_File_Name (New_Unit_Name.all) &
              ".ads");

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

      Close (Output_File);

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

      if not Data.Generic_Kind then
         S_Put (0, "with AUnit.Test_Caller;");
      end if;
      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,
                      "(Standard."                    &
                      Data.Test_Unit_Full_Name.all    &
                      "."                             &
                      Current_Type.Test_Type_Name.all &
                      ");");
            else
               S_Put
                 (5,
                  "(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
      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 (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) &
                   "_"                                                       &
                   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 (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 (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 (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.Test_Unit_Full_Name.all              &
                      " : "                                     &
                      Data.TR_List.Element (K).TR_Text_Name.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 (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 (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.Test_Unit_Full_Name.all                      &
                   " (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);
            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 (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 (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 (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 (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);
      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 & ";");
      Close (Output_File);

      if not Data.Generic_Kind then
         String_List.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_Liskov_Unit_Name : constant String :=
        Data.Test_Unit_Full_Name.all & "." & Liskov_Instant_Suite_Name;

      Generate_Liskov : Boolean := False;

      Cur : String_List.Cursor;
   begin

      Create (Output_File,
              Out_File,
              Output_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);

      String_List.Append (Suit_List, New_Unit_Name);

      Cur := Good_For_Liskov_Inst.First;
      loop
         exit when Cur = String_List.No_Element;

         if Data.Gen_Unit_Full_Name.all = String_List.Element (Cur) then
            Generate_Liskov := True;
         end if;

         String_List.Next (Cur);
      end loop;

      if not Generate_Liskov then
         return;
      end if;

      Create (Output_File,
              Out_File,
              Output_Dir.all                           &
              Unit_To_File_Name (New_Liskov_Unit_Name) &
              ".ads");

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

      String_List.Append (Suit_List, New_Liskov_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
     (Type_Decl    : Asis.Element;
      Target_Unit  : Asis.Compilation_Unit)
      return Natural
   is
      Dec_Elem : Asis.Element := Type_Decl;
      Def_Elem : Asis.Element;
      Count : Natural := 0;

      Zero_Level_Unit : constant Asis.Compilation_Unit :=
        Enclosing_Compilation_Unit (Type_Decl);
   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;

         Dec_Elem := Corresponding_Parent_Subtype (Def_Elem);

         Count := Count + 1;

         if
           Is_Equal (Zero_Level_Unit, Enclosing_Compilation_Unit (Dec_Elem))
         then
            exit when
              Is_Equal (Enclosing_Compilation_Unit
                (Corresponding_Generic_Package
                   (Enclosing_Element (Dec_Elem))),
                Target_Unit);
         else
            exit when
              Is_Equal (Enclosing_Compilation_Unit (Dec_Elem), Target_Unit);
         end if;

      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 ("aunitglue: " & 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
                 ("aunitglue: 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_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;

   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;

      --  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
      Apropriate_Source : Boolean := True;

      Data : Data_Holder;

   begin

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

         if not Data.Generic_Kind then
            if
              Liskov_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_Liskov := True;

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

            if Liskov_Suite and then Data.Good_For_Liskov then
               Generate_Liskov_Suite (Data);
            end if;
         end if;

      end if;

      Data.Test_Types.Clear;
      Data.TR_List.Clear;
      Data.ITR_List.Clear;
      Data.LTR_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

      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;

   end Process_Sources;

   -----------------------
   --  Project_Creator  --
   -----------------------
   procedure Project_Creator
   is
      Tmp : String_Access;
   begin
      Create (Output_File,
              Out_File,
              Output_Dir.all & "test_driver.gpr");

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

      if Source_Prj.all /= "" then
         S_Put (0, "with """   &
                Source_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
               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;

      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"", ""-gnat05"", " &
         """-gnatyM0"", ""-gnata"");");
      New_Line (Output_File);
      S_Put (3, "end Compiler;");
      New_Line (Output_File);
      New_Line (Output_File);

      S_Put (0, "end Test_Driver;");

      Close (Output_File);

      if Suppress_Contacts then
         Create (Output_File,
                 Out_File,
                 Output_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;

   -------------
   --  S_Put  --
   -------------

   procedure S_Put (Span : Natural; Text : String) is
   begin
      for J in 0 .. Span - 1 loop
         Put (Output_File, " ");
      end loop;
      Put (Output_File, Text);
   end S_Put;

   -----------------------
   --  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 ("aunitglue: cannot delete " &
                     Last_Context_Name.all & ".adt");
      end if;

      Delete_File (Last_Context_Name.all & ".ali", Success);
      if not Success then
         Report_Std ("aunitglue: 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 : String_List.Cursor;
   begin
      if String_List.Is_Empty (Suit_List) then
         Report_Std ("aunitglue: 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,
              Output_Dir.all & Unit_To_File_Name (Main_Suite_Name) & ".ads");
      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 & ";");
      Close (Output_File);

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

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

         S_Put
           (0,
            "with " & String_List.Element (Iterator) & ";");
         New_Line (Output_File);

         String_List.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 := String_List.First (Suit_List);
      loop
         exit when Iterator = String_List.No_Element;

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

         String_List.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 & ";");

      Close (Output_File);

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

      S_Put (0, "with AUnit.Reporter.Text;");
      New_Line (Output_File);
      S_Put (0, "with AUnit.Run;");
      New_Line (Output_File);
      S_Put (0, "with " & Main_Suite_Name & "; use " & Main_Suite_Name & ";");
      New_Line (Output_File);
      New_Line (Output_File);
      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.Text.Text_Reporter;");
      New_Line (Output_File);
      S_Put (0, "begin");
      New_Line (Output_File);
      S_Put (3, "Runner (Reporter);");
      New_Line (Output_File);
      S_Put (0, "end " & Test_Runner_Name & ";");

      Close (Output_File);

   end Test_Runner_Generator;

   -------------------------
   --  Unit_To_File_Name  --
   -------------------------

   function Unit_To_File_Name (Old : String) return String is
      T : String_Access;
   begin
      T := new String'(Old);
      for J in T.all'First .. T.all'Last loop
         if T.all (J) = '.' then
            T.all (J) := '-';
         end if;
      end loop;

      return To_Lower (T.all);
   end Unit_To_File_Name;

end AUnitGlue.Generator;
