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

pragma Ada_2005;

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

with GNAT.OS_Lib;                use GNAT.OS_Lib;
with GNAT.SHA1;

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.Expressions;           use Asis.Expressions;
with Asis.Extensions;            use Asis.Extensions;
with Asis.Errors;
with Asis.Exceptions;            use Asis.Exceptions;
with Asis.Implementation;
with Asis.Iterator;              use Asis.Iterator;
with Asis.Text;                  use Asis.Text;

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

with AUnitStub.Source_Table;     use AUnitStub.Source_Table;
with AUnitStub.Common;           use AUnitStub.Common;
with AUnitStub.Options;          use AUnitStub.Options;
with AUnitStub.Environment;      use AUnitStub.Environment;

package body AUnitStub.Stub_Generator is

   -------------------
   --  Minded Data  --
   -------------------

   New_Tests_Counter : Natural := 0;
   All_Tests_Counter : Natural := 0;

   package Tests_Per_Unit is new
     Ada.Containers.Indefinite_Ordered_Maps (String, Natural);
   use Tests_Per_Unit;

   Test_Info : Tests_Per_Unit.Map;

   type Data_Kind_Type is
     (Declaration_Data,
      Instantiation);

   type Type_Info is tagged record
      Main_Type_Elem            : Asis.Element := Asis.Nil_Element;
      Main_Type_Abstract        : Boolean;
      Main_Type_Text_Name       : String_Access;

      Has_Argument_Father       : Boolean;
      Argument_Father_Unit_Name : String_Access;
      Argument_Father_Type_Name : String_Access;
      Argument_Father_Nesting   : String_Access;

      Has_Root_Nesting_Ancestor : Boolean;
      Root_Nesting_Ancestor     : String_Access;

      Nesting                   : String_Access;
      Parent_In_Same_Unit       : Boolean;
      Type_Number               : Positive;

      No_Default_Discriminant   : Boolean;
   end record;

   package Type_Info_List is new
     Ada.Containers.Indefinite_Doubly_Linked_Lists (Type_Info);
   use Type_Info_List;

   type Base_Type_Info is new Type_Info with record
      Nested_Descendants : Type_Info_List.List;
   end record;

   package Type_Info_Vect is new
     Ada.Containers.Indefinite_Vectors (Positive, Base_Type_Info);
   use Type_Info_Vect;

   type Test_Case_Mode is (Normal, Robustness);

   type Test_Case_Info is record
      Pre  : Asis.Element;
      Post : Asis.Element;

      Name : String_Access;
      Mode : Test_Case_Mode;
      Req  : Asis.Element;
      Ens  : Asis.Element;

      Req_Image : String_Access;
      Ens_Image : String_Access;
   end record;

   type Subp_Info is record
      Subp_Declaration : Asis.Declaration;
      Subp_Text_Name   : String_Access;
      Subp_Mangle_Name : String_Access;
      Is_Abstract      : Boolean;
      Corresp_Type     : Natural;
      Nesting          : String_Access;

      Has_TC_Info      : Boolean := False;
      TC_Info          : Test_Case_Info;
   end record;

   package Subp_Data_List is new
     Ada.Containers.Indefinite_Doubly_Linked_Lists (Subp_Info);
   use Subp_Data_List;

   type Package_Info is record
      Name       : String_Access;
      Is_Generic : Boolean;
      Data_Kind  : Data_Kind_Type;
   end record;

   package Package_Info_List is new
     Ada.Containers.Doubly_Linked_Lists (Package_Info);
   use Package_Info_List;

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

      Unit : Asis.Compilation_Unit;
      --  CU itself.

      Unit_Full_Name : String_Access;
      --  Fully expanded Ada name of the CU.

      Unit_File_Name : String_Access;
      --  Short name of the file, containing the CU.

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

         when Declaration_Data =>

            Is_Generic       : Boolean;
            --  Indicates if given argument package declaration is generic.

            Has_Simple_Case  : Boolean := False;
            --  Indicates if we have routines that are not primitives of any
            --  tagged type.

            Needs_Fixtures   : Boolean := False;
            --  Indicates if we need to unclude AUnit.Fixtures in the test
            --  package.

            Needs_Set_Up     : Boolean := False;
            --  Indicates if we need the Set_Up routine for at least one test
            --  type;

            Needs_Assertions : Boolean := False;
            --  Indicates if we need to include AUnit.Assertions into the body
            --  of the test package.

            Subp_List : Subp_Data_List.List;
            --  List of subprograms declared in the argument package
            --  declaration.

            Type_Data_List : Type_Info_Vect.Vector;
            --  Stores info on tagged records in the argument package
            --  declaration.

            Nested_Type_Data_List : Type_Info_List.List;
            --  Stores info on tagged records declared in nested packages that
            --  do not have parent types in root level package.

            Package_Data_List : Package_Info_List.List;
            --  Stores info of nested packages.

         when Instantiation =>

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

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

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

      end case;

   end record;

   package Element_List is new
     Ada.Containers.Doubly_Linked_Lists (Asis.Element, Is_Equal);

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

   package Name_Set is new
     Ada.Containers.Indefinite_Ordered_Maps (String, Positive);

   use Element_List;
   use String_List;
   use Name_Set;

   type Generic_Tests is record
      Gen_Unit_Full_Name : String_Access;
      Tested_Type_Names  : String_List.List;
      Has_Simple_Case    : Boolean := False;
   end record;
   --  Stores names of all tested type names, that produce names of generic
   --  test pachages, which should be instantiated
   --  if we have an instantiation of the tested package.

   package Generic_Tests_Storage is new
     Ada.Containers.Indefinite_Doubly_Linked_Lists (Generic_Tests);
   use Generic_Tests_Storage;

   Gen_Tests_Storage : Generic_Tests_Storage.List;
   --  List of data on all the generic tests created during the processing of
   --  generic tested packages.

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

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

   Test_Routine_Prefix     : constant String := "Test_";
   --  Prefix to each test routine

   Wrapper_Prefix          : constant String := "Wrap_";

   EM_Package_Name         : constant String := "Env_Mgmt";
   --  Name of the package that contains all the Set_Up routines;

   Test_Unit_Name          : constant String := "Tests";
   --  Name of test child package for non-primitive tests.

   Test_Unit_Name_Suff     : constant String := "_Tests";
   --  Suffix for test packages that correspond to tagged record types.

   Test_Prj_Prefix         : constant String := "test_";
   --  Prefix of the output project file name.

   Gen_Test_Unit_Name      : constant String := "Gen_Tests";
   --  Name of generic test child package for non-primitive tests.

   Gen_Test_Unit_Name_Suff : constant String := "_Gen_Tests";
   --  Suffix for generic test packages that correspond to tagged record types.

   Inst_Test_Unit_Name     : constant String := "Inst_Tests";
   --  Name of instatiation test child package.

   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 generates them if the
   --  source is appropriate (contains one or less tagged type declaration).

   procedure Gather_Data
     (The_Unit          :     Asis.Compilation_Unit;
      Data              : out Data_Holder;
      Apropriate_Source : out Boolean);
   --  Iterates through the given unit and gathers all the data needed for
   --  generation of test package. 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.

   function Get_Subp_Name (Subp : Asis.Element) return String;
   --  if Subp is a subprigram declaration it will return subprogram's name;
   --  if Subp is an overloaded operator - it's text name

   function Operator_Image (Op : Defining_Name) return String;
   --  According to operator symbols returns their literal names to make the
   --  names of the testing routines correct.

   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 Parent_Type_Declaration
     (Type_Dec : Asis.Element) return Asis.Element;
   --  Returns a corresponding parent type declaration for a given tagged type
   --  extension declaration.

   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.

   procedure Generate_Test_Package (Data : Data_Holder);
   --  Generates test package spec and body. Completely regeneratable.

   procedure Generate_Function_Wrapper
     (Current_Subp : Subp_Info; Declaration_Only : Boolean := False);
   --  Print a test-case specific wrapper for tested function.

   procedure Generate_Procedure_Wrapper
     (Current_Subp : Subp_Info; Declaration_Only : Boolean := False);
   --  Print a test-case specific wrapper for tested function.

   procedure Generate_Stubs (Data : Data_Holder);
   --  Generates stubs for those routines that do not have tests already.

   procedure Print_Comment_Declaration (Subp : Subp_Info; Span : Natural := 0);
   --  Prints the file containing the tested subprogram as well as the line
   --  coloumn numbers of the tested subprogram declaration.

   procedure Print_Comment_Separate (Subp : Subp_Info; Span : Natural := 0);
   --  Prints commented image of tested subprogram with given span.

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

   procedure Generate_Test_Package_Instantiation (Data : Data_Holder);
   --  Generates an instatiation of the corresponding generic test package

   procedure Generate_Project_File;
   --  Generates a project file that sets the value of Source_Dirs
   --  with the directories whe generated tests are placed and includes
   --  the argument project file.

   ------------------------
   -- Nesting processing --
   ------------------------

   type Nesting_Difference_Type is (Inner, Outer, No_Difference);

   function Nesting_Comparable (Nesting_1, Nesting_2 : String) return Boolean;
   pragma Unreferenced (Nesting_Comparable);
   --  Checks if nestings of can be compared.

   function Nesting_Common_Prefix
     (Nesting_1, Nesting_2 : String) return String;
   --  Returns the common prefix of two nestings.

   function Nesting_Difference_Kind
     (Nesting_1, Nesting_2 : String) return Nesting_Difference_Type;
   pragma Unreferenced (Nesting_Difference_Kind);
   --  Compares two nestings.

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

   procedure Specs_By_Nesting_Difference
     (Prev, Next   : String;
      Package_Data : Package_Info_List.List;
      Simple_Case  : Boolean := False);
   --  Prints the opening and closing parts of nested package specifications
   --  based on nesting difference. In simple case mode adds test package
   --  suffixes to nested test package names.

   procedure Bodies_By_Nesting_Difference
     (Prev, Next   : String;
      Current_Unit : in out String_Access;
      Output_Dir   : String;
      Simple_Case  : Boolean := False);
   --  Prints the opening and closing parts of nested package separate bodies
   --  based on nesting difference.
   --  Updates the value of Current_Unit indicating which separate is
   --  currently opened.
   --  In simple case mode adds test package suffixes to nested test package
   --  names.

   function Dot_Count (Str : String) return Natural;
   --  Returns the number of '.' in argument string.

   function Get_Pack
     (Pack         : String;
      Package_Data : Package_Info_List.List)
      return Package_Info;
   --  Get package info using expanded package name.

   function Locate_Previous_Generic
     (Arg : String; Package_Data : Package_Info_List.List) return String;
   --  Looks back trough nesting of the given package for an enclosing
   --  generic package. If found, cuts the head, replacing generic package
   --  name with "Tested".

   ---------------
   -- Dot_Count --
   ---------------

   function Dot_Count (Str : String) return Natural is
         N : Natural := 0;
   begin
      for I in Str'Range loop
         if Str (I) = '.' then
            N := N + 1;
         end if;
      end loop;
      return N;
   end Dot_Count;

   ----------------------------------
   -- Bodies_By_Nesting_Difference --
   ----------------------------------
   procedure Bodies_By_Nesting_Difference
     (Prev, Next   : String;
      Current_Unit : in out String_Access;
      Output_Dir   : String;
      Simple_Case  : Boolean := False)
   is

      Idx : Integer;

      Nest_Diff : String_Access;

      Common : constant String := Nesting_Common_Prefix (Prev, Next);

      New_Unit : String_Access := new String'(Current_Unit.all);
      Swap     : String_Access;
      New_File : String_Access;

      function Enclosing_Nesting (Arg : String) return String;

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

   begin
      if Prev /= Common then

         Nest_Diff := new String'(Nesting_Difference (Common, Prev));

         Idx := Nest_Diff'Last;

         for I in reverse Nest_Diff'Range loop
            if Nest_Diff (I) = '.' then

               if Simple_Case then
                  S_Put
                    (0,
                     "end " &
                     Nest_Diff (I + 1 .. Idx) &
                     "_Tests;");
               else
                  S_Put
                    (0,
                     "end " &
                     Nest_Diff (I + 1 .. Idx) &
                     ";");
               end if;
               New_Line (Output_File);
               Close (Output_File);

               New_File := new String'
                 (Unit_To_File_Name (Enclosing_Nesting (New_Unit.all)));
               Open
                 (Output_File,
                  Append_File,
                  Output_Dir & Directory_Separator & New_File.all & ".adb");
               Free (New_File);

               Swap := new String'
                 (Enclosing_Nesting (New_Unit.all));
               Free (New_Unit);
               New_Unit := new String'(Swap.all);
               Free (Swap);

               Idx := I - 1;
            end if;

            if I = Nest_Diff'First then

               if Simple_Case then
                  S_Put
                    (0,
                     "end " &
                     Nest_Diff (I .. Idx) &
                     "_Tests;");
               else
                  S_Put
                    (0,
                     "end " &
                     Nest_Diff (I .. Idx) &
                     ";");
               end if;
               New_Line (Output_File);
               Close (Output_File);

               New_File := new String'
                 (Unit_To_File_Name (Enclosing_Nesting (New_Unit.all)));
               Open
                 (Output_File,
                  Append_File,
                  Output_Dir & Directory_Separator & New_File.all & ".adb");
               Free (New_File);

               Swap := new String'
                 (Enclosing_Nesting (New_Unit.all));
               Free (New_Unit);
               New_Unit := new String'(Swap.all);
               Free (Swap);

               Idx := I - 1;
            end if;
         end loop;

         Free (Nest_Diff);

      end if;

      if Next /= Common then

         Nest_Diff := new String'(Nesting_Difference (Common, Next));

         Idx := Nest_Diff'First;

         for I in Nest_Diff'Range loop
            if Nest_Diff (I) = '.' then
               if Simple_Case then
                  S_Put (3,
                         "package body "           &
                         Nest_Diff (Idx .. I - 1)  &
                         "_Tests"                  &
                         " is separate;");

                  New_File := new String'
                    (Unit_To_File_Name (New_Unit.all &
                     "." & Nest_Diff (Idx .. I - 1) & "_Tests"));
               else
                  S_Put (3,
                         "package body "           &
                         Nest_Diff (Idx .. I - 1)  &
                         " is separate;");

                  New_File := new String'
                    (Unit_To_File_Name (New_Unit.all &
                     "." & Nest_Diff (Idx .. I - 1)));
               end if;
               New_Line (Output_File);
               Close (Output_File);

               Create
                 (Output_File,
                  Out_File,
                  Output_Dir & Directory_Separator & New_File.all & ".adb");
               Free (New_File);

               S_Put
                 (0,
                  "separate (" & New_Unit.all & ")");
               New_Line (Output_File);

               if Simple_Case then
                  S_Put
                    (0,
                     "package body " &
                     Nest_Diff (Idx .. I - 1) &
                     "_Tests" &
                     " is");
               else
                  S_Put
                    (0,
                     "package body " &
                     Nest_Diff (Idx .. I - 1) &
                     " is");
               end if;
               New_Line (Output_File);

               if Simple_Case then
                  Swap := new String'
                    (New_Unit.all & "." & Nest_Diff (Idx .. I - 1) &
                     "_Tests");
               else
                  Swap := new String'
                    (New_Unit.all & "." & Nest_Diff (Idx .. I - 1));
               end if;
               Free (New_Unit);
               New_Unit := new String'(Swap.all);
               Free (Swap);

               Idx := I + 1;
            end if;

            if I = Nest_Diff'Last then

               if Simple_Case then
                  S_Put (3,
                         "package body "           &
                         Nest_Diff (Idx .. I)  &
                         "_Tests"                  &
                         " is separate;");

                  New_File := new String'
                    (Unit_To_File_Name (New_Unit.all &
                     "." & Nest_Diff (Idx .. I) & "_Tests"));
               else
                  S_Put (3,
                         "package body "           &
                         Nest_Diff (Idx .. I)  &
                         " is separate;");

                  New_File := new String'
                    (Unit_To_File_Name (New_Unit.all &
                     "." & Nest_Diff (Idx .. I)));
               end if;

               New_Line (Output_File);
               Close (Output_File);

               Create
                 (Output_File,
                  Out_File,
                  Output_Dir & Directory_Separator & New_File.all & ".adb");
               Free (New_File);

               S_Put
                 (0,
                  "separate (" & New_Unit.all & ")");
               New_Line (Output_File);
               if Simple_Case then
                  S_Put
                    (0,
                     "package body " &
                     Nest_Diff (Idx .. I) &
                     "_Tests" &
                     " is");
               else
                  S_Put
                    (0,
                     "package body " &
                     Nest_Diff (Idx .. I) &
                     " is");
               end if;
               New_Line (Output_File);
               New_Line (Output_File);

               if Simple_Case then
                  Swap := new String'
                    (New_Unit.all & "." & Nest_Diff (Idx .. I) &
                     "_Tests");
               else
                  Swap := new String'
                    (New_Unit.all & "." & Nest_Diff (Idx .. I));
               end if;
               Free (New_Unit);
               New_Unit := new String'(Swap.all);
               Free (Swap);

               Idx := I + 1;
            end if;

         end loop;

         Free (Nest_Diff);

      end if;

      Free (Current_Unit);
      Current_Unit := new String'(New_Unit.all);
      Free (New_Unit);

   end Bodies_By_Nesting_Difference;

   ---------------------------------
   -- Specs_By_Nesting_Difference --
   ---------------------------------

   procedure Specs_By_Nesting_Difference
     (Prev, Next   : String;
      Package_Data : Package_Info_List.List;
      Simple_Case  : Boolean := False)
   is

      Span : Natural;

      Idx : Integer;

      Nest_Diff : String_Access;

      Common : constant String := Nesting_Common_Prefix (Prev, Next);

   begin

      if Prev /= Common then

         Nest_Diff := new String'(Nesting_Difference (Common, Prev));

         Span := 3 * Dot_Count (Prev);

         Idx := Nest_Diff'Last;

         for I in reverse Nest_Diff'Range loop
            if Nest_Diff (I) = '.' then

               if Simple_Case then
                  S_Put
                    (Span,
                     "end " &
                     Nest_Diff (I + 1 .. Idx) &
                     Test_Unit_Name_Suff &
                     ";");
               else
                  S_Put
                    (Span,
                     "end " &
                     Nest_Diff (I + 1 .. Idx) &
                     ";");
               end if;

               New_Line (Output_File);
               New_Line (Output_File);
               Span := Span - 3;
               Idx := I - 1;
            end if;

            if I = Nest_Diff'First then

               if Simple_Case then
                  S_Put
                    (Span,
                     "end " &
                     Nest_Diff (I .. Idx) &
                     Test_Unit_Name_Suff &
                     ";");
               else
                  S_Put
                    (Span,
                     "end " &
                     Nest_Diff (I .. Idx) &
                     ";");
               end if;

               New_Line (Output_File);
               New_Line (Output_File);
               Span := Span - 3;
               Idx := I - 1;
            end if;
         end loop;

         Free (Nest_Diff);

      end if;

      if Next /= Common then

         Nest_Diff := new String'(Nesting_Difference (Common, Next));

         Span := 3 + 3 * Dot_Count (Common);

         Idx := Nest_Diff'First;

         for I in Nest_Diff'Range loop
            if Nest_Diff (I) = '.' then

               if
                 Get_Pack
                   (Common & "." & Nest_Diff (Nest_Diff'First .. I - 1),
                    Package_Data).Is_Generic
               then
                  S_Put (Span, "generic");
                  New_Line (Output_File);
                  S_Put
                    (Span + 3,
                     "with package Tested is new "              &
                     Locate_Previous_Generic
                       (Common & "." &
                        Nest_Diff (Nest_Diff'First .. Idx - 1),
                        Package_Data)                           &
                     Nest_Diff (Nest_Diff'First .. I - 1)       &
                     " (<>);");
                  New_Line (Output_File);
               end if;

               if Simple_Case then
                  S_Put
                    (Span,
                     "package " &
                     Nest_Diff (Idx .. I - 1) &
                     Test_Unit_Name_Suff &
                     " is");
               else
                  S_Put
                    (Span,
                     "package " &
                     Nest_Diff (Idx .. I - 1) &
                     " is");
               end if;

               New_Line (Output_File);
               New_Line (Output_File);
               Span := Span + 3;
               Idx := I + 1;
            end if;

            if I = Nest_Diff'Last then

               if
                 Get_Pack
                   (Common & "." & Nest_Diff (Nest_Diff'First .. I),
                    Package_Data).Is_Generic
               then
                  S_Put (Span, "generic");
                  New_Line (Output_File);
                  S_Put
                    (Span + 3,
                     "with package Tested is new "              &
                     Locate_Previous_Generic
                       (Common & "." &
                        Nest_Diff (Nest_Diff'First .. Idx - 1),
                        Package_Data)                           &
                     Nest_Diff (Nest_Diff'First .. I)           &
                     " (<>);");
                  New_Line (Output_File);
               end if;

               if Simple_Case then
                  S_Put
                    (Span,
                     "package " &
                     Nest_Diff (Idx .. I) &
                     Test_Unit_Name_Suff &
                     " is");
               else
                  S_Put
                    (Span,
                     "package " &
                     Nest_Diff (Idx .. I) &
                     " is");
               end if;

               New_Line (Output_File);
               New_Line (Output_File);
               Span := Span + 3;
               Idx := I + 1;
            end if;

         end loop;

         Free (Nest_Diff);

      end if;

   end Specs_By_Nesting_Difference;

   --------------
   -- Get_Pack --
   --------------

   function Get_Pack
     (Pack         : String;
      Package_Data : Package_Info_List.List)
      return Package_Info
   is
      Nil_Info : constant Package_Info :=
        (Name       => new String'(""),
         Is_Generic => False,
         Data_Kind  => Declaration_Data);
      Cur : Package_Info_List.Cursor;
   begin
      Cur := Package_Data.First;
      loop
         exit when Cur = Package_Info_List.No_Element;

         if Package_Info_List.Element (Cur).Name.all = Pack then
            return Package_Info_List.Element (Cur);
         end if;

         Package_Info_List.Next (Cur);
      end loop;

      return Nil_Info;
   end Get_Pack;

   -----------------------------
   -- Locate_Previous_Generic --
   -----------------------------

   function Locate_Previous_Generic
     (Arg : String; Package_Data : Package_Info_List.List) return String
   is
      Pack : Package_Info;
   begin

      if Get_Pack (Arg, Package_Data).Is_Generic then
         return "Tested";
      end if;

      for I in reverse Arg'Range loop

         if Arg (I) = '.' then
            Pack := Get_Pack (Arg (Arg'First .. I - 1), Package_Data);
            if Pack.Name.all /= "" and then Pack.Is_Generic then
               return "Tested." & Arg (I + 1 .. Arg'Last);
            end if;
         end if;

      end loop;

      return Arg;

   end Locate_Previous_Generic;

   ---------------------------
   -- Nesting_Common_Prefix --
   ---------------------------

   function Nesting_Common_Prefix
     (Nesting_1, Nesting_2 : String) return String
   is
      L1, L2   : Integer;
      Last_Dot : Integer;
   begin
      L1 := Nesting_1'First;
      L2 := Nesting_2'First;
      loop

         if Nesting_1 (L1) = Nesting_2 (L2) then

            if L1 = Nesting_1'Last then
               return Nesting_1;
            end if;

            if L2 = Nesting_2'Last then
               return Nesting_2;
            end if;

            if Nesting_1 (L1) = '.' then
               Last_Dot := L1;
            end if;

            L1 := L1 + 1;
            L2 := L2 + 1;
         else
            return Nesting_1 (Nesting_1'First .. Last_Dot - 1);
         end if;

      end loop;

   end Nesting_Common_Prefix;

   ------------------------
   -- Nesting_Comparable --
   ------------------------

   function Nesting_Comparable (Nesting_1, Nesting_2 : String) return Boolean
   is
      L : constant Integer := Integer'Min (Nesting_1'Length, Nesting_2'Length);
   begin
      return
        Nesting_1 (Nesting_1'First .. L) = Nesting_2 (Nesting_2'First .. L);
   end Nesting_Comparable;

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

   -----------------------------
   -- Nesting_Difference_Kind --
   -----------------------------

   function Nesting_Difference_Kind
     (Nesting_1, Nesting_2 : String) return Nesting_Difference_Type is
   begin

      if Nesting_1'Length > Nesting_2'Length then
         return Outer;
      end if;

      if Nesting_1'Length < Nesting_2'Length then
         return Inner;
      end if;

      return No_Difference;

   end Nesting_Difference_Kind;

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

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

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

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

   -------------------------------
   -- Generate_Function_Wrapper --
   -------------------------------

   procedure Generate_Function_Wrapper
     (Current_Subp : Subp_Info; Declaration_Only : Boolean := False)
   is
   begin
      S_Put
        (3,
         "function " &
         Wrapper_Prefix &
         Current_Subp.Subp_Mangle_Name.all);
      declare
         Params : constant
           Asis.Parameter_Specification_List := Parameter_Profile
             (Current_Subp.Subp_Declaration);
         Result : constant Asis.Element :=
           Result_Profile (Current_Subp.Subp_Declaration);

         Result_Image : constant String :=
           Trim (To_String (Element_Image (Result)), Both);
      begin
         for I in Params'Range loop
            if I = Params'First then
               S_Put (0, " (");
            end if;
            S_Put
              (0,
               Trim
                 (To_String (Element_Image (Params (I))),
                  Both));
            if I = Params'Last then
               S_Put
                 (0,
                  ") ");
            else
               S_Put (0, "; ");
            end if;
         end loop;

         S_Put (0, "return " & Result_Image);

         if Declaration_Only then
            return;
         end if;

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

         if Current_Subp.TC_Info.Req_Image.all /= "" then
            S_Put (6, "Assert");
            New_Line (Output_File);
            S_Put
              (8,
               "(" &
               Current_Subp.TC_Info.Req_Image.all &
               ",");
            New_Line (Output_File);
            S_Put
              (9,
               """" &
               Current_Subp.TC_Info.Name.all &
               " precondition violated"");");
            New_Line (Output_File);
         end if;

         S_Put (6, "declare");
         New_Line (Output_File);
         S_Put
           (9,
            Current_Subp.Subp_Mangle_Name.all &
            "_Result : constant " &
            Result_Image &
            " := " &
            Current_Subp.Subp_Text_Name.all);

         if Params'Length = 0 then
            S_Put (0, ";");
         else
            S_Put (1, "(");
            for I in Params'Range loop
               S_Put
                 (0,
                  To_String (Defining_Name_Image
                    (First_Name (Params (I)))));
               if I = Params'Last then
                  S_Put (0, ");");
               else
                  S_Put (0, ", ");
               end if;
            end loop;
         end if;

         New_Line (Output_File);

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

         if Current_Subp.TC_Info.Ens_Image.all /= "" then
            S_Put (9, "Assert");
            New_Line (Output_File);
            S_Put
              (11,
               "(" &
               Current_Subp.TC_Info.Ens_Image.all &
               ",");
            New_Line (Output_File);
            S_Put
              (12,
               """" &
               Current_Subp.TC_Info.Name.all &
               " postcondition violated"");");
            New_Line (Output_File);
         end if;

         S_Put
           (9,
            "return " &
            Current_Subp.Subp_Mangle_Name.all &
            "_Result;");
         New_Line (Output_File);

         S_Put (6, "end;");
         New_Line (Output_File);

         S_Put
           (3,
            "end " &
            Wrapper_Prefix &
            Current_Subp.Subp_Mangle_Name.all &
            ";");
         New_Line (Output_File);
      end;
   end Generate_Function_Wrapper;

   --------------------------------
   -- Generate_Procedure_Wrapper --
   --------------------------------

   procedure Generate_Procedure_Wrapper
     (Current_Subp : Subp_Info; Declaration_Only : Boolean := False)
   is
   begin
      S_Put
        (3,
         "procedure " &
         Wrapper_Prefix &
         Current_Subp.Subp_Mangle_Name.all);
      declare
         Params : constant
           Asis.Parameter_Specification_List := Parameter_Profile
             (Current_Subp.Subp_Declaration);
      begin
         for I in Params'Range loop
            if I = Params'First then
               S_Put (0, " (");
            end if;
            S_Put
              (0,
               Trim
                 (To_String (Element_Image (Params (I))),
                  Both));
            if I = Params'Last then
               S_Put
                 (0,
                  ") ");
            else
               S_Put (0, "; ");
            end if;
         end loop;

         if Declaration_Only then
            return;
         end if;

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

         if Current_Subp.TC_Info.Req_Image.all /= "" then
            S_Put (6, "Assert");
            New_Line (Output_File);
            S_Put
              (8,
               "(" &
               Current_Subp.TC_Info.Req_Image.all &
               ",");
            New_Line (Output_File);
            S_Put
              (9,
               """" &
               Current_Subp.TC_Info.Name.all &
               " precondition violated"");");
            New_Line (Output_File);
         end if;

         S_Put (6, Current_Subp.Subp_Text_Name.all);

         if Params'Length = 0 then
            S_Put (0, ";");
         else
            S_Put (1, "(");
            for I in Params'Range loop
               S_Put
                 (0,
                  To_String (Defining_Name_Image
                    (First_Name (Params (I)))));
               if I = Params'Last then
                  S_Put (0, ");");
               else
                  S_Put (0, ", ");
               end if;
            end loop;
         end if;

         New_Line (Output_File);

         if Current_Subp.TC_Info.Ens_Image.all /= "" then
            S_Put (6, "Assert");
            New_Line (Output_File);
            S_Put
              (8,
               "(" &
               Current_Subp.TC_Info.Ens_Image.all &
               ",");
            New_Line (Output_File);
            S_Put
              (9,
               """" &
               Current_Subp.TC_Info.Name.all &
               " postcondition violated"");");
            New_Line (Output_File);
         end if;

         S_Put
           (3,
            "end " &
            Wrapper_Prefix &
            Current_Subp.Subp_Mangle_Name.all &
            ";");
         New_Line (Output_File);
      end;
   end Generate_Procedure_Wrapper;

   -----------------------------
   --  Generate_Project_File  --
   -----------------------------
   procedure Generate_Project_File is
      Tmp_Str : String_Access;
      package Srcs is new
        Ada.Containers.Indefinite_Ordered_Sets (String);
      use Srcs;

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

      Output_Prj : String_Access;

   begin
      Reset_Source_Iterator;
      loop
         Tmp_Str := new String'(Next_Source_Name);
         exit when Tmp_Str.all = "";

         Include (Out_Dirs, Get_Source_Output_Dir (Tmp_Str.all));
         Free (Tmp_Str);
      end loop;

      if Source_Prj.all /= "" then
         Tmp_Str :=
           new String'(Normalize_Pathname (Name => Dir_Name (Source_Prj.all),
                                           Case_Sensitive => False));
         Output_Prj :=
           new String'(Tmp_Str.all &
                       Directory_Separator &
                       Test_Prj_Prefix &
                       Base_Name (Source_Prj.all));

      else
         --  That's a stub for now, for it's difficult to decide where to put
         --  the output project file if we do not have an argument one.
         return;
      end if;

      Create (Output_File,
              Out_File,
              Output_Prj.all);

      S_Put (0, "with ""aunit"";");
      New_Line (Output_File);
      S_Put (0, "with """ & Source_Prj.all & """;");
      New_Line (Output_File);
      S_Put
        (0,
         "project "                                                  &
         Test_Prj_Prefix                                             &
         Base_Name (Source_Prj.all, File_Extension (Source_Prj.all)) &
         " is");
      New_Line (Output_File);
      New_Line (Output_File);
      S_Put (3, "for Source_Dirs use");
      New_Line (Output_File);

      Out_Dirs_Cur := Out_Dirs.First;
      S_Put (5, "(""" & Srcs.Element (Out_Dirs_Cur) & """");
      loop
         Srcs.Next (Out_Dirs_Cur);
         exit when Out_Dirs_Cur = Srcs.No_Element;

         S_Put (0, ",");
         New_Line (Output_File);
         S_Put (6, """" & Srcs.Element (Out_Dirs_Cur) & """");

      end loop;
      S_Put (0, ");");
      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_Prj_Prefix                                             &
         Base_Name (Source_Prj.all, File_Extension (Source_Prj.all)) &
         ";");
      Close (Output_File);

   end Generate_Project_File;

   -----------------------------
   --  Generate_Test_Package  --
   -----------------------------

   procedure Generate_Test_Package (Data : Data_Holder) is

      Output_Dir             : constant String :=
        Get_Source_Output_Dir (Data.Unit_File_Name.all);

      Test_File_Name : String_Access;
      Unit_Name      : String_Access;

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

      Subp_Cur     : Subp_Data_List.Cursor;
      Type_Cur     : Type_Info_List.Cursor;

      Current_Type : Base_Type_Info;
      --  The test type for which the primitives are
      --  put togather in the corresponding test package

      Current_N_Type : Type_Info;
      --  Nested type

      Test_Unit_Suffix : String_Access;
      --  Generic or non-generic test package suffix or.

      Actual_Test : Boolean;
      --  Indicates if current test package has at least one non-abstract test
      --  routine. In that case we need to include AUnit.Assertions.

      Gen_Tests : Generic_Tests;
      --  Used to store all test type names in case of generic tested package.
      --  They are to be added at generic test storage.

      Current_Nesting : String_Access;
      Current_Unit    : String_Access;
      Span : Natural;

      Nesting_Add : String_Access;

   begin

      if Data.Is_Generic then
         Test_Unit_Suffix := new String'(Gen_Test_Unit_Name_Suff);
         Gen_Tests.Gen_Unit_Full_Name := new String'(Data.Unit_Full_Name.all);
      else
         Test_Unit_Suffix := new String'(Test_Unit_Name_Suff);
      end if;

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

         Current_Type := Data.Type_Data_List.Element (I);

         Actual_Test := False;

         if Data.Is_Generic then
            Unit_Name := new
              String'(Data.Unit_Full_Name.all              &
                      "."                                  &
                      Current_Type.Main_Type_Text_Name.all &
                      Gen_Test_Unit_Name_Suff);

            Gen_Tests.Tested_Type_Names.Append
              (Current_Type.Main_Type_Text_Name.all);
         else
            Unit_Name := new
              String'(Data.Unit_Full_Name.all              &
                      "."                                  &
                      Current_Type.Main_Type_Text_Name.all &
                      Test_Unit_Name_Suff);
         end if;

         Test_File_Name := new String'(Unit_To_File_Name (Unit_Name.all));

         ----------------------------------
         --  Creating test package spec  --
         ----------------------------------

         Create
           (Output_File,
            Out_File,
            Output_Dir & Directory_Separator & Test_File_Name.all & ".ads");

         if not Current_Type.Has_Argument_Father then
            S_Put (0, "with AUnit.Test_Fixtures;");
         else
            if
              Current_Type.Argument_Father_Unit_Name.all =
                Current_Type.Argument_Father_Nesting.all
            then
               --  ??? Test_Unit_Suffix is not quite appropriate here.
               --  To be replaced with proper check.
               S_Put
                 (0,
                  "with "                                    &
                  Current_Type.Argument_Father_Unit_Name.all &
                  "."                                        &
                  Current_Type.Argument_Father_Type_Name.all &
                  Test_Unit_Suffix.all                       &
                  ";");
            else
               if Current_Type.Has_Root_Nesting_Ancestor then
                  S_Put
                    (0,
                     "with "                                      &
                     Current_Type.Argument_Father_Unit_Name.all   &
                     "."                                          &
                     Current_Type.Root_Nesting_Ancestor.all       &
                     Test_Unit_Suffix.all                         &
                     ";");
               end if;
            end if;
         end if;
         New_Line (Output_File);
         New_Line (Output_File);

         if Data.Is_Generic then
            S_Put (0, "generic");
            New_Line (Output_File);
         end if;

         S_Put (0, "package " & Unit_Name.all & " is");
         New_Line (Output_File);
         New_Line (Output_File);

         if Current_Type.Has_Argument_Father then
            --  Declaring test type extension from another test type.
            S_Put
              (3,
               "type Test_" &
               Current_Type.Main_Type_Text_Name.all);
            if Current_Type.Main_Type_Abstract then
               S_Put (0, " is abstract new");
            else
               S_Put (0, " is new");
            end if;
            New_Line (Output_File);

            if
              Current_Type.Argument_Father_Unit_Name.all /=
                Current_Type.Argument_Father_Nesting.all
            then
               Nesting_Add := new String'
                 (Nesting_Difference
                    (Current_Type.Argument_Father_Unit_Name.all,
                     Current_Type.Argument_Father_Nesting.all) &
                  ".");
            else
               Nesting_Add := new String'("");
            end if;

            S_Put
              (5,
               "Standard."                                &
               Current_Type.Argument_Father_Unit_Name.all &
               ".");
            if Current_Type.Has_Root_Nesting_Ancestor then
               S_Put
                 (0,
                  Current_Type.Root_Nesting_Ancestor.all &
                  Test_Unit_Suffix.all & ".");
            end if;
            S_Put
              (0,
               Nesting_Add.all                              &
               Current_Type.Argument_Father_Type_Name.all   &
               Test_Unit_Suffix.all                         &
               ".Test_"                                     &
               Current_Type.Argument_Father_Type_Name.all   &
               " with null record;");

            Free (Nesting_Add);

         else
            --  Declaring access type to tested type.
            S_Put
              (3,
               "type "                              &
               Current_Type.Main_Type_Text_Name.all &
               "_Access is access all "             &
               Current_Type.Main_Type_Text_Name.all &
               "'Class;");
            New_Line (Output_File);
            New_Line (Output_File);

            --  Declaring root test type.
            S_Put
              (3,
               "type Test_"                         &
               Current_Type.Main_Type_Text_Name.all &
               " is");
            if Current_Type.Main_Type_Abstract then
               S_Put (0, " abstract");
            end if;
            S_Put (0, " new AUnit.Test_Fixtures.Test_Fixture");
            New_Line (Output_File);
            S_Put (3, "with record");
            New_Line (Output_File);
            S_Put
              (6,
               "Fixture : "                         &
               Current_Type.Main_Type_Text_Name.all &
               "_Access;");
            New_Line (Output_File);
            S_Put (3, "end record;");
         end if;

         New_Line (Output_File);
         New_Line (Output_File);

         --  Declaring Set_Up and Tear_Down routines.
         if not Current_Type.Main_Type_Abstract then
            S_Put
              (3,
               "procedure Set_Up (T : in out Test_" &
               Current_Type.Main_Type_Text_Name.all &
               ");");
            New_Line (Output_File);
            S_Put
              (3,
               "procedure Tear_Down (T : in out Test_" &
               Current_Type.Main_Type_Text_Name.all &
               ");");
            New_Line (Output_File);
            New_Line (Output_File);
         end if;

         --  Adding test routine declarations.
         Subp_Cur := Data.Subp_List.First;
         loop
            exit when Subp_Cur = Subp_Data_List.No_Element;

            if
              Subp_Data_List.Element (Subp_Cur).Corresp_Type =
              Current_Type.Type_Number
            then

               S_Put
                 (3,
                  "procedure "                                           &
                  Subp_Data_List.Element (Subp_Cur).Subp_Mangle_Name.all &
                  " (T : in out Test_"                                   &
                  Current_Type.Main_Type_Text_Name.all                   &
                  ")");

               if Subp_Data_List.Element (Subp_Cur).Is_Abstract then
                  S_Put (0, " is abstract;");
               else
                  S_Put (0, ";");
                  Actual_Test := True;
               end if;

               New_Line (Output_File);
               Print_Comment_Declaration
                 (Subp_Data_List.Element (Subp_Cur), 3);
               New_Line (Output_File);
            end if;

            Subp_Data_List.Next (Subp_Cur);
         end loop;

         --  Adding nested packages
         Current_Nesting := new String'(Current_Type.Nesting.all);

         Type_Cur := Current_Type.Nested_Descendants.First;
         loop
            exit when Type_Cur = Type_Info_List.No_Element;

            Current_N_Type := Type_Info_List.Element (Type_Cur);

            Specs_By_Nesting_Difference
              (Current_Nesting.all,
               Current_N_Type.Nesting.all,
               Data.Package_Data_List);

            Free (Current_Nesting);
            Current_Nesting := new String'
              (Current_N_Type.Nesting.all);

            Span := 3 + 3 * Dot_Count (Current_Nesting.all);

            S_Put
              (Span,
               "package " & Current_N_Type.Main_Type_Text_Name.all &
               "_Tests is");
            New_Line (Output_File);

            if Current_N_Type.Has_Argument_Father then
               --  Declaring test type extension from another test type.
               S_Put
                 (Span + 3,
                  "type Test_" &
                  Current_N_Type.Main_Type_Text_Name.all);
               if Current_N_Type.Main_Type_Abstract then
                  S_Put (0, " is abstract new");
               else
                  S_Put (0, " is new");
               end if;
               New_Line (Output_File);

               if
                 Current_N_Type.Argument_Father_Unit_Name.all /=
                   Current_N_Type.Argument_Father_Nesting.all
               then
                  Nesting_Add := new String'
                    (Nesting_Difference
                       (Current_N_Type.Argument_Father_Unit_Name.all,
                        Current_N_Type.Argument_Father_Nesting.all) &
                     ".");
               else
                  Nesting_Add := new String'("");
               end if;

               if
                 Current_N_Type.Argument_Father_Unit_Name.all =
                   Current_N_Type.Argument_Father_Nesting.all
               then
                  S_Put
                    (Span + 5,
                     "Standard."                                  &
                     Current_N_Type.Argument_Father_Unit_Name.all &
                     "."                                          &
                     Nesting_Add.all                              &
                     Current_N_Type.Argument_Father_Type_Name.all &
                     Test_Unit_Suffix.all                         &
                     ".Test_"                                     &
                     Current_N_Type.Argument_Father_Type_Name.all &
                     " with null record;");
               else
                  S_Put
                    (Span + 5,
                     "Standard."                                  &
                     Current_N_Type.Argument_Father_Unit_Name.all &
                     "."                                          &
                     Current_N_Type.Root_Nesting_Ancestor.all     &
                     Test_Unit_Suffix.all                         &
                     "."                                          &
                     Nesting_Add.all                              &
                     Current_N_Type.Argument_Father_Type_Name.all &
                     Test_Unit_Suffix.all                         &
                     ".Test_"                                     &
                     Current_N_Type.Argument_Father_Type_Name.all &
                     " with null record;");
               end if;

               Free (Nesting_Add);

            else
               --  Declaring access type to tested type.
               S_Put
                 (Span + 3,
                  "type "                                &
                  Current_N_Type.Main_Type_Text_Name.all &
                  "_Access is access all "               &
                  Current_N_Type.Main_Type_Text_Name.all &
                  "'Class;");
               New_Line (Output_File);
               New_Line (Output_File);

               --  Declaring root test type.
               S_Put
                 (Span + 3,
                  "type Test_"                           &
                  Current_N_Type.Main_Type_Text_Name.all &
                  " is");
               if Current_N_Type.Main_Type_Abstract then
                  S_Put (0, " abstract");
               end if;
               S_Put (0, " new AUnit.Test_Fixtures.Test_Fixture");
               New_Line (Output_File);
               S_Put (Span + 3, "with record");
               New_Line (Output_File);
               S_Put
                 (Span + 6,
                  "Fixture : "                           &
                  Current_N_Type.Main_Type_Text_Name.all &
                  "_Access;");
               New_Line (Output_File);
               S_Put (Span + 3, "end record;");
            end if;

            New_Line (Output_File);
            New_Line (Output_File);

            --  Declaring Set_Up and Tear_Down routines.
            if not Current_N_Type.Main_Type_Abstract then
               S_Put
                 (Span + 3,
                  "procedure Set_Up (T : in out Test_"   &
                  Current_N_Type.Main_Type_Text_Name.all &
                  ");");
               New_Line (Output_File);
               S_Put
                 (Span + 3,
                  "procedure Tear_Down (T : in out Test_" &
                  Current_N_Type.Main_Type_Text_Name.all  &
                  ");");
               New_Line (Output_File);
               New_Line (Output_File);
            end if;

            --  Adding test routine declarations.
            Subp_Cur := Data.Subp_List.First;
            loop
               exit when Subp_Cur = Subp_Data_List.No_Element;

               if
                 Subp_Data_List.Element (Subp_Cur).Corresp_Type =
                 Current_N_Type.Type_Number
               then
                  S_Put
                    (Span + 3,
                     "procedure "                                           &
                     Subp_Data_List.Element (Subp_Cur).Subp_Mangle_Name.all &
                     " (T : in out Test_"                                   &
                     Current_N_Type.Main_Type_Text_Name.all                 &
                     ")");

                  if Subp_Data_List.Element (Subp_Cur).Is_Abstract then
                     S_Put (0, " is abstract;");
                  else
                     S_Put (0, ";");
                     Actual_Test := True;
                  end if;

                  New_Line (Output_File);
                  Print_Comment_Declaration
                    (Subp_Data_List.Element (Subp_Cur),
                     Span + 3);
                  New_Line (Output_File);
               end if;

               Subp_Data_List.Next (Subp_Cur);
            end loop;

            S_Put
              (Span,
               "end " & Current_N_Type.Main_Type_Text_Name.all &
               "_Tests;");
            New_Line (Output_File);

            Next (Type_Cur);
         end loop;

         Specs_By_Nesting_Difference
           (Current_Nesting.all,
            Current_Type.Nesting.all,
            Data.Package_Data_List);
         Free (Current_Nesting);

         S_Put (0, "end " & Unit_Name.all & ";");

         Close (Output_File);

         ----------------------------------
         --  Creating test package body  --
         ----------------------------------

         if Actual_Test or (not Current_Type.Main_Type_Abstract) then
            Create
              (Output_File,
               Out_File,
               Output_Dir & Directory_Separator & Test_File_Name.all & ".adb");

            S_Put (0, "with AUnit.Assertions; use AUnit.Assertions;");
            New_Line (Output_File);
            New_Line (Output_File);

            S_Put (0, "package body " & Unit_Name.all & " is");
            New_Line (Output_File);
            New_Line (Output_File);

            --  Declaring Environment Management packages
            if not Current_Type.Main_Type_Abstract then
               S_Put
                 (3,
                  "package "           &
                  EM_Package_Name &
                  " is");
               New_Line (Output_File);
               S_Put
                 (6,
                  "procedure User_Set_Up (T : in out Test_" &
                  Current_Type.Main_Type_Text_Name.all      &
                  ");");
               New_Line (Output_File);
               S_Put
                 (6,
                  "procedure User_Tear_Down (T : in out Test_" &
                  Current_Type.Main_Type_Text_Name.all         &
                  ");");
               New_Line (Output_File);
               S_Put
                 (3,
                  "end "               &
                  EM_Package_Name &
                  ";");
               New_Line (Output_File);
               S_Put
                 (3,
                  "package body "      &
                  EM_Package_Name &
                  " is separate;");
               New_Line (Output_File);
               New_Line (Output_File);

               --  Declaring Set_Up and Tear_Down bodies.
               S_Put
                 (3,
                  "procedure Set_Up (T : in out Test_" &
                  Current_Type.Main_Type_Text_Name.all &
                  ") is");
               New_Line (Output_File);
               S_Put (3, "begin");
               New_Line (Output_File);
               S_Put
                 (6,
                  EM_Package_Name &
                  ".User_Set_Up (T);");
               New_Line (Output_File);
               S_Put (3, "end Set_Up;");

               New_Line (Output_File);
               New_Line (Output_File);
               S_Put
                 (3,
                  "procedure Tear_Down (T : in out Test_" &
                  Current_Type.Main_Type_Text_Name.all    &
                  ") is");
               New_Line (Output_File);
               S_Put (3, "begin");
               New_Line (Output_File);
               S_Put
                 (6,
                  EM_Package_Name &
                  ".User_Tear_Down (T);");
               New_Line (Output_File);
               S_Put (3, "end Tear_Down;");
               New_Line (Output_File);
               New_Line (Output_File);

            end if;

            --  Adding test routine body stubs.
            Subp_Cur := Data.Subp_List.First;
            loop
               exit when Subp_Cur = Subp_Data_List.No_Element;

               if
                 Subp_Data_List.Element (Subp_Cur).Corresp_Type =
                 Current_Type.Type_Number
               then
                  if not Subp_Data_List.Element (Subp_Cur).Is_Abstract then

                     if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then

                        case
                          Declaration_Kind
                            (Subp_Data_List.Element
                                 (Subp_Cur).Subp_Declaration)
                        is

                           when A_Function_Declaration =>
                              Generate_Function_Wrapper
                                (Subp_Data_List.Element (Subp_Cur));

                           when A_Procedure_Declaration =>
                              Generate_Procedure_Wrapper
                                (Subp_Data_List.Element (Subp_Cur));

                           when others =>
                              null;

                        end case;

                     end if;

                     S_Put
                       (3,
                        "procedure "                         &
                        Subp_Data_List.Element
                          (Subp_Cur).Subp_Mangle_Name.all    &
                        " (T : in out Test_"                 &
                        Current_Type.Main_Type_Text_Name.all &
                        ") is separate;");

                     New_Line (Output_File);
                     Print_Comment_Declaration
                       (Subp_Data_List.Element (Subp_Cur), 3);
                     New_Line (Output_File);
                  end if;
               end if;

               Subp_Data_List.Next (Subp_Cur);
            end loop;

            --  Adding nested package bodies
            Current_Nesting := new String'(Current_Type.Nesting.all);
            Current_Unit    := new String'(Unit_Name.all);

            Type_Cur := Current_Type.Nested_Descendants.First;
            loop
               exit when Type_Cur = Type_Info_List.No_Element;

               Current_N_Type := Type_Info_List.Element (Type_Cur);

               Bodies_By_Nesting_Difference
                 (Current_Nesting.all,
                  Current_N_Type.Nesting.all,
                  Current_Unit,
                  Output_Dir);

               Free (Current_Nesting);
               Current_Nesting := new String'
                 (Current_N_Type.Nesting.all);

               S_Put (3,
                      "package body " &
                      Current_N_Type.Main_Type_Text_Name.all &
                      "_Tests is separate;");
               New_Line (Output_File);

               Close (Output_File);

               Create
                 (Output_File,
                  Out_File,
                  Output_Dir & Directory_Separator &
                  Unit_To_File_Name
                    (Current_Unit.all & "."                 &
                     Current_N_Type.Main_Type_Text_Name.all &
                     "_Tests")                     &
                  ".adb");

               S_Put (0,
                      "separate (" & Current_Unit.all & ")");
               New_Line (Output_File);
               S_Put (0,
                      "package body "                        &
                      Current_N_Type.Main_Type_Text_Name.all &
                      "_Tests is");
               New_Line (Output_File);
               New_Line (Output_File);

               --  Declaring Environment Management packages
               if not Current_N_Type.Main_Type_Abstract then
                  S_Put
                    (3,
                     "package "      &
                     EM_Package_Name &
                     " is");
                  New_Line (Output_File);
                  S_Put
                    (6,
                     "procedure User_Set_Up (T : in out Test_"   &
                     Current_N_Type.Main_Type_Text_Name.all      &
                     ");");
                  New_Line (Output_File);
                  S_Put
                    (6,
                     "procedure User_Tear_Down (T : in out Test_"   &
                     Current_N_Type.Main_Type_Text_Name.all         &
                     ");");
                  New_Line (Output_File);
                  S_Put
                    (3,
                     "end "          &
                     EM_Package_Name &
                     ";");
                  New_Line (Output_File);
                  S_Put
                    (3,
                     "package body " &
                     EM_Package_Name &
                     " is separate;");
                  New_Line (Output_File);
                  New_Line (Output_File);

                  --  Declaring Set_Up and Tear_Down bodies.
                  S_Put
                    (3,
                     "procedure Set_Up (T : in out Test_"   &
                     Current_N_Type.Main_Type_Text_Name.all &
                     ") is");
                  New_Line (Output_File);
                  S_Put (3, "begin");
                  New_Line (Output_File);
                  S_Put
                    (6,
                     EM_Package_Name &
                     ".User_Set_Up (T);");
                  New_Line (Output_File);
                  S_Put (3, "end Set_Up;");

                  New_Line (Output_File);
                  New_Line (Output_File);
                  S_Put
                    (3,
                     "procedure Tear_Down (T : in out Test_"   &
                     Current_N_Type.Main_Type_Text_Name.all    &
                     ") is");
                  New_Line (Output_File);
                  S_Put (3, "begin");
                  New_Line (Output_File);
                  S_Put
                    (6,
                     EM_Package_Name &
                     ".User_Tear_Down (T);");
                  New_Line (Output_File);
                  S_Put (3, "end Tear_Down;");
                  New_Line (Output_File);
                  New_Line (Output_File);

                  --  Adding test routine body stubs.
                  Subp_Cur := Data.Subp_List.First;
                  loop
                     exit when Subp_Cur = Subp_Data_List.No_Element;

                     if
                       Subp_Data_List.Element (Subp_Cur).Corresp_Type =
                       Current_N_Type.Type_Number
                     then
                        if
                        not Subp_Data_List.Element (Subp_Cur).Is_Abstract
                        then

                           if
                             Subp_Data_List.Element (Subp_Cur).Has_TC_Info
                           then

                              case
                                Declaration_Kind
                                  (Subp_Data_List.Element
                                       (Subp_Cur).Subp_Declaration)
                              is
                                 when A_Function_Declaration =>
                                    Generate_Function_Wrapper
                                      (Subp_Data_List.Element (Subp_Cur));

                                 when A_Procedure_Declaration =>
                                    Generate_Procedure_Wrapper
                                      (Subp_Data_List.Element (Subp_Cur));

                                 when others =>
                                    null;

                              end case;

                           end if;

                           S_Put
                             (3,
                              "procedure "                           &
                              Subp_Data_List.Element
                                (Subp_Cur).Subp_Mangle_Name.all      &
                              " (T : in out Test_"                   &
                              Current_N_Type.Main_Type_Text_Name.all &
                              ") is separate;");

                           New_Line (Output_File);
                           Print_Comment_Declaration
                             (Subp_Data_List.Element
                                (Subp_Cur),
                              3);
                           New_Line (Output_File);
                        end if;
                     end if;

                     Subp_Data_List.Next (Subp_Cur);
                  end loop;

               end if;

               S_Put (0,
                      "end "                                 &
                      Current_N_Type.Main_Type_Text_Name.all &
                      "_Tests;");

               Close (Output_File);
               Open
                 (Output_File,
                  Append_File,
                  Output_Dir & Directory_Separator &
                  Unit_To_File_Name (Current_Unit.all) & ".adb");

               Next (Type_Cur);
            end loop;

            Bodies_By_Nesting_Difference
              (Current_Nesting.all,
               Current_Type.Nesting.all,
               Current_Unit,
               Output_Dir);
            Free (Current_Nesting);

            S_Put (0, "end " & Unit_Name.all & ";");

            Close (Output_File);
         end if;

      end loop;

      if Data.Has_Simple_Case then
         if Data.Is_Generic then
            Unit_Name := new
              String'(Data.Unit_Full_Name.all &
                      "."                     &
                      Gen_Test_Unit_Name);

            Gen_Tests.Has_Simple_Case := True;
         else
            Unit_Name := new
              String'(Data.Unit_Full_Name.all &
                      "."                     &
                      Test_Unit_Name);
         end if;

         Test_File_Name := new String'(Unit_To_File_Name (Unit_Name.all));

         --  Generating simple test package spec.
         Create
           (Output_File,
            Out_File,
            Output_Dir & Directory_Separator & Test_File_Name.all & ".ads");

         S_Put (0, "with AUnit.Test_Fixtures;");
         New_Line (Output_File);
         New_Line (Output_File);
         if Data.Is_Generic then
            S_Put (0, "generic");
            New_Line (Output_File);
         end if;

         S_Put (0, "package " & Unit_Name.all & " is");
         New_Line (Output_File);
         New_Line (Output_File);

         --  Declaring simple test type.
         S_Put
           (3,
            "type Test is new AUnit.Test_Fixtures.Test_Fixture");
         New_Line (Output_File);
         S_Put (3, "with null record;");
         New_Line (Output_File);
         New_Line (Output_File);

         --  Declaring Set_Up and Tear_Down routines for simple tests.
         S_Put (3, "procedure Set_Up (T : in out Test);");
         New_Line (Output_File);
         S_Put (3, "procedure Tear_Down (T : in out Test);");
         New_Line (Output_File);
         New_Line (Output_File);

         --  Adding test routine declarations.
         Current_Nesting := new String'(Data.Unit_Full_Name.all);
         Span := 3;

         Subp_Cur := Data.Subp_List.First;
         loop
            exit when Subp_Cur = Subp_Data_List.No_Element;

            if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then

               Specs_By_Nesting_Difference
                 (Current_Nesting.all,
                  Subp_Data_List.Element (Subp_Cur).Nesting.all,
                  Data.Package_Data_List,
                  Simple_Case => True);

               Free (Current_Nesting);
               Current_Nesting := new String'
                 (Subp_Data_List.Element (Subp_Cur).Nesting.all);
               Span := 3 * Dot_Count (Current_Nesting.all);

               S_Put
                 (Span + 3,
                  "procedure "                                           &
                  Subp_Data_List.Element (Subp_Cur).Subp_Mangle_Name.all &
                  " (T : in out Test);");

               New_Line (Output_File);
               Print_Comment_Declaration
                 (Subp_Data_List.Element (Subp_Cur),
                  3 + Span);
               New_Line (Output_File);
            end if;

            Subp_Data_List.Next (Subp_Cur);
         end loop;

         Specs_By_Nesting_Difference
           (Current_Nesting.all,
            Data.Unit_Full_Name.all,
            Data.Package_Data_List,
            Simple_Case => True);

         S_Put (0, "end " & Unit_Name.all & ";");

         Close (Output_File);

         --  Generating simple test package body
         Create
           (Output_File,
            Out_File,
            Output_Dir & Directory_Separator & Test_File_Name.all & ".adb");

         S_Put (0, "with AUnit.Assertions; use AUnit.Assertions;");
         New_Line (Output_File);
         New_Line (Output_File);

         S_Put (0, "package body " & Unit_Name.all & " is");
         New_Line (Output_File);
         New_Line (Output_File);

         --  Declaring Environment Management packages
         S_Put
           (3,
            "package "           &
            EM_Package_Name &
            " is");
         New_Line (Output_File);
         S_Put
           (6,
            "procedure User_Set_Up (T : in out Test);");
         New_Line (Output_File);
         S_Put
           (6,
            "procedure User_Tear_Down (T : in out Test);");
         New_Line (Output_File);
         S_Put
           (3,
            "end "               &
            EM_Package_Name &
            ";");
         New_Line (Output_File);
         S_Put
           (3,
            "package body "      &
            EM_Package_Name &
            " is separate;");
         New_Line (Output_File);
         New_Line (Output_File);

         --  Declaring Set_Up and Tear_Down bodies.
         S_Put (3, "procedure Set_Up (T : in out Test) is");
         New_Line (Output_File);
         S_Put (3, "begin");
         New_Line (Output_File);
         S_Put (6,
                EM_Package_Name &
                ".User_Set_Up (T);");
         New_Line (Output_File);
         S_Put (3, "end Set_Up;");
         New_Line (Output_File);
         S_Put (3, "procedure Tear_Down (T : in out Test) is");
         New_Line (Output_File);
         S_Put (3, "begin");
         New_Line (Output_File);
         S_Put (6,
                EM_Package_Name &
                ".User_Tear_Down (T);");
         New_Line (Output_File);
         S_Put (3, "end Tear_Down;");
         New_Line (Output_File);
         New_Line (Output_File);

         --  Adding test routine body stubs.
         Current_Nesting := new String'(Data.Unit_Full_Name.all);
         Current_Unit := new String'(Unit_Name.all);

         Subp_Cur := Data.Subp_List.First;
         loop
            exit when Subp_Cur = Subp_Data_List.No_Element;

            if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then

               Bodies_By_Nesting_Difference
                 (Current_Nesting.all,
                  Subp_Data_List.Element (Subp_Cur).Nesting.all,
                  Current_Unit,
                  Output_Dir,
                  Simple_Case => True);

               Free (Current_Nesting);
               Current_Nesting := new String'
                 (Subp_Data_List.Element (Subp_Cur).Nesting.all);

               if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then

                  case
                    Declaration_Kind
                      (Subp_Data_List.Element (Subp_Cur).Subp_Declaration)
                  is

                     when A_Function_Declaration =>
                        Generate_Function_Wrapper
                          (Subp_Data_List.Element (Subp_Cur));

                     when A_Procedure_Declaration =>
                        Generate_Procedure_Wrapper
                          (Subp_Data_List.Element (Subp_Cur));

                     when others =>
                        null;

                  end case;

               end if;

               S_Put
                 (3,
                  "procedure "                                           &
                  Subp_Data_List.Element (Subp_Cur).Subp_Mangle_Name.all &
                  " (T : in out Test) is separate;");

               New_Line (Output_File);
               Print_Comment_Declaration
                 (Subp_Data_List.Element (Subp_Cur), 3);
               New_Line (Output_File);
            end if;

            Subp_Data_List.Next (Subp_Cur);
         end loop;

         Bodies_By_Nesting_Difference
           (Current_Nesting.all,
            Data.Unit_Full_Name.all,
            Current_Unit,
            Output_Dir,
            Simple_Case => True);
         Free (Current_Nesting);

         S_Put (0, "end " & Unit_Name.all & ";");

         Close (Output_File);

      end if;

      if Data.Is_Generic then
         Gen_Tests_Storage.Append (Gen_Tests);
      end if;

   end Generate_Test_Package;

   -------------------------------------------
   --  Generate_Test_Package_Instantiation  --
   -------------------------------------------

   procedure Generate_Test_Package_Instantiation (Data : Data_Holder) is
      Output_Dir     : constant String :=
        Get_Source_Output_Dir (Data.Unit_File_Name.all);
      New_Unit_Name  : String_Access;
      Test_File_Name : String_Access;

      Cur_Stor  : Generic_Tests_Storage.Cursor;
      Gen_Tests : Generic_Tests;
      Cur_Test  : String_List.Cursor;
   begin

      Cur_Stor := Gen_Tests_Storage.First;
      loop
         exit when Cur_Stor = Generic_Tests_Storage.No_Element;

         Gen_Tests := Generic_Tests_Storage.Element (Cur_Stor);

         if Gen_Tests.Gen_Unit_Full_Name.all = Data.Gen_Unit_Full_Name.all then
            Cur_Test := Gen_Tests.Tested_Type_Names.First;
            loop
               exit when Cur_Test = String_List.No_Element;

               New_Unit_Name :=
                 new String'(Data.Unit_Full_Name.all        &
                             "."                            &
                             String_List.Element (Cur_Test) &
                             "_"                            &
                             Inst_Test_Unit_Name);
               Test_File_Name :=
                 new String'(Unit_To_File_Name (New_Unit_Name.all));

               Create (Output_File,
                       Out_File,
                       Output_Dir & Directory_Separator &
                       Test_File_Name.all & ".ads");

               S_Put
                 (0,
                  "with "                        &
                  Data.Gen_Unit_Full_Name.all    &
                  "."                            &
                  String_List.Element (Cur_Test) &
                  Gen_Test_Unit_Name_Suff        &
                  ";");
               New_Line (Output_File);
               New_Line (Output_File);
               S_Put (0, "package " & New_Unit_Name.all & " is new");
               New_Line (Output_File);
               S_Put (2,
                      Data.Unit_Full_Name.all        &
                      "."                            &
                      String_List.Element (Cur_Test) &
                      Gen_Test_Unit_Name_Suff        &
                      ";");

               Close (Output_File);

               String_List.Next (Cur_Test);
            end loop;

            if Gen_Tests.Has_Simple_Case then

               New_Unit_Name :=
                 new String'(Data.Unit_Full_Name.all        &
                             "."                            &
                             Inst_Test_Unit_Name);
               Test_File_Name :=
                 new String'(Unit_To_File_Name (New_Unit_Name.all));

               Create (Output_File,
                       Out_File,
                       Output_Dir & Directory_Separator &
                       Test_File_Name.all & ".ads");

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

               Close (Output_File);

            end if;

            exit;
         end if;

         Generic_Tests_Storage.Next (Cur_Stor);
      end loop;

   end Generate_Test_Package_Instantiation;

   ----------------------
   --  Generate_Stubs  --
   ----------------------

   procedure Generate_Stubs (Data : Data_Holder) is
      Output_Dir             : constant String :=
        Get_Source_Output_Dir (Data.Unit_File_Name.all);

      Unit_Name          : String_Access;
      --  Test package unit name.

      New_Unit_Full_Name : String_Access;

      Separate_Unit_Name : String_Access;
      --  Full name of the separated unit.

      Separate_File_Name : String_Access;
      --  File name for the separated unit.

      Separated_Name     : String_Access;
      --  Unit name of the separated test routine of environment management.

      Current_Type   : Type_Info;
      Current_B_Type : Base_Type_Info;
      Current_Subp : Subp_Info;

      Current_N_Type : Type_Info;

      Subp_Cur : Subp_Data_List.Cursor;
      Type_Cur : Type_Info_List.Cursor;

      procedure Set_Current_Type (Type_Numb : Natural);
      --  Looks trough types and nested types and sets the value of
      --  Current_Type with correspondig element.

      function Convert_To_Simple_Case_Nesting (Arg : String) return String;
      --  Converts given nesting to corresponding nesting for non-primitive
      --  tested subprograms.

      function Convert_To_Simple_Case_Nesting (Arg : String) return String
      is
         Idx : Integer := Arg'First;
         Res, Swap : String_Access;
      begin
         Res := new String'("");
         for I in Arg'Range loop
            if Arg (I) = '.' then
               Swap := new String'
                 (Res.all & Arg (Idx .. I - 1) &
                  "_Tests");  --  A stub, no genericy yet.
               Free (Res);
               Res := new String'(Swap.all);
               Free (Swap);
               Idx := I;
            end if;

         end loop;

         return Res.all & Arg (Idx .. Arg'Last) &
         "_Tests";  --  A stub, no genericy yet.
      end Convert_To_Simple_Case_Nesting;

      procedure Set_Current_Type (Type_Numb : Natural) is
         Nesteds : Type_Info_List.List;
         Cur     : Type_Info_List.Cursor;
      begin

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

            if
              Data.Type_Data_List.Element (I).Type_Number = Type_Numb
            then
               Current_Type   := Type_Info (Data.Type_Data_List.Element (I));
               Current_B_Type := Data.Type_Data_List.Element (I);

               exit;
            else
               Nesteds :=
                 Data.Type_Data_List.Element (I).Nested_Descendants;
               Cur := Nesteds.First;
               loop
                  exit when Cur = Type_Info_List.No_Element;

                  if
                    Type_Info_List.Element (Cur).Type_Number = Type_Numb
                  then
                     Current_Type := Type_Info_List.Element (Cur);
                     exit;
                  end if;

                  Type_Info_List.Next (Cur);
               end loop;
            end if;

         end loop;

      end Set_Current_Type;

   begin

      Test_Info.Include (Data.Unit_File_Name.all, 0);

      if Data.Has_Simple_Case then

         if Data.Is_Generic then
            Unit_Name := new
              String'(Data.Unit_Full_Name.all &
                      "."                     &
                      Gen_Test_Unit_Name);
         else
            Unit_Name := new
              String'(Data.Unit_Full_Name.all &
                      "."                     &
                      Test_Unit_Name);
         end if;

         Separate_Unit_Name := new
           String'(Unit_Name.all &
                   "."           &
                   EM_Package_Name);

         Separate_File_Name := new
           String'(Unit_To_File_Name (Separate_Unit_Name.all) & ".adb");

         if not Is_Regular_File
           (Output_Dir & Directory_Separator & Separate_File_Name.all)
         then

            Create
              (Output_File,
               Out_File,
               Output_Dir & Directory_Separator & Separate_File_Name.all);

            S_Put (0, "separate (" & Unit_Name.all & ")");
            New_Line (Output_File);
            S_Put (0, "package body " & EM_Package_Name & " is");
            New_Line (Output_File);
            New_Line (Output_File);
            S_Put (3, "procedure User_Set_Up (T : in out Test) is");
            New_Line (Output_File);
            S_Put (3, "begin");
            New_Line (Output_File);
            S_Put (6, "null;");
            New_Line (Output_File);
            S_Put (3, "end User_Set_Up;");
            New_Line (Output_File);
            New_Line (Output_File);
            S_Put (3, "procedure User_Tear_Down (T : in out Test) is");
            New_Line (Output_File);
            S_Put (3, "begin");
            New_Line (Output_File);
            S_Put (6, "null;");
            New_Line (Output_File);
            S_Put (3, "end User_Tear_Down;");
            New_Line (Output_File);
            New_Line (Output_File);
            S_Put (0, "end " & EM_Package_Name & ";");

            Close (Output_File);

         end if;

         Free (Separate_Unit_Name);
         Free (Separate_File_Name);
         Free (Separated_Name);

      end if;

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

         Set_Current_Type (Data.Type_Data_List.Element (I).Type_Number);

         if not Current_Type.Main_Type_Abstract then

            Separated_Name := new String'(EM_Package_Name);

            if Data.Is_Generic then
               Unit_Name := new
                 String'(Data.Unit_Full_Name.all              &
                         "."                                  &
                         Current_Type.Main_Type_Text_Name.all &
                         Gen_Test_Unit_Name_Suff);
            else
               Unit_Name := new
                 String'(Data.Unit_Full_Name.all              &
                         "."                                  &
                         Current_Type.Main_Type_Text_Name.all &
                         Test_Unit_Name_Suff);
            end if;

            Separate_Unit_Name := new
              String'(Unit_Name.all &
                      "."           &
                      Separated_Name.all);

            Separate_File_Name := new
              String'(Unit_To_File_Name (Separate_Unit_Name.all) & ".adb");

            if not Is_Regular_File
              (Output_Dir & Directory_Separator & Separate_File_Name.all)
            then

               Create
                 (Output_File,
                  Out_File,
                  Output_Dir & Directory_Separator &
                  Separate_File_Name.all);

               S_Put (0, "separate (" & Unit_Name.all & ")");
               New_Line (Output_File);
               S_Put (0, "package body " & Separated_Name.all & " is");
               New_Line (Output_File);

               if Current_Type.No_Default_Discriminant then
                  S_Put
                    (3,
                     "--  Local_"                         &
                     Current_Type.Main_Type_Text_Name.all &
                     " : aliased "                        &
                     Current_Type.Main_Type_Text_Name.all &
                     ";");
                  New_Line (Output_File);
                  S_Put
                    (3,
                     "procedure User_Set_Up (T : in out Test_" &
                     Current_Type.Main_Type_Text_Name.all      &
                     ") is");
                  New_Line (Output_File);

                  S_Put (3, "begin");
                  New_Line (Output_File);
                  S_Put
                    (6, "null;");
                  New_Line (Output_File);
                  S_Put
                    (6, "--  T.Fixture := Local_"         &
                     Current_Type.Main_Type_Text_Name.all &
                     "'Access;");
                  New_Line (Output_File);
                  S_Put (3, "end User_Set_Up;");
               else
                  S_Put
                    (3,
                     "Local_"                             &
                     Current_Type.Main_Type_Text_Name.all &
                     " : aliased "                        &
                     Current_Type.Main_Type_Text_Name.all &
                     ";");
                  New_Line (Output_File);
                  S_Put
                    (3,
                     "procedure User_Set_Up (T : in out Test_" &
                     Current_Type.Main_Type_Text_Name.all      &
                     ") is");
                  New_Line (Output_File);

                  S_Put (3, "begin");
                  New_Line (Output_File);
                  S_Put
                    (6, "T.Fixture := Local_"             &
                     Current_Type.Main_Type_Text_Name.all &
                     "'Access;");
                  New_Line (Output_File);
                  S_Put (3, "end User_Set_Up;");
               end if;

               New_Line (Output_File);
               New_Line (Output_File);
               S_Put
                 (3,
                  "procedure User_Tear_Down (T : in out Test_" &
                  Current_Type.Main_Type_Text_Name.all         &
                  ") is");
               New_Line (Output_File);

               S_Put (3, "begin");
               New_Line (Output_File);
               S_Put
                 (6, "null;");
               New_Line (Output_File);
               S_Put (3, "end User_Tear_Down;");
               New_Line (Output_File);
               S_Put (0, "end " & Separated_Name.all & ";");

               Close (Output_File);

            end if;

            Free (Separate_Unit_Name);
            Free (Separate_File_Name);
            Free (Separated_Name);

         end if;

         --  Adding nested Env_Mgmt
         Type_Cur := Current_B_Type.Nested_Descendants.First;
         loop
            exit when Type_Cur = Type_Info_List.No_Element;

            Current_N_Type := Type_Info_List.Element (Type_Cur);

            if not Current_N_Type.Main_Type_Abstract then

               Separated_Name := new String'(EM_Package_Name);

               if Data.Is_Generic then
                  Unit_Name := new String'
                    (Data.Unit_Full_Name.all                    &
                     "."                                        &
                     Current_N_Type.Root_Nesting_Ancestor.all &
                     Gen_Test_Unit_Name_Suff                    &
                     "."                                        &
                     Nesting_Difference
                       (Current_N_Type.Nesting.all,
                        Data.Unit_Full_Name.all)                &
                     "."                                        &
                     Current_N_Type.Main_Type_Text_Name.all     &
                     "_Tests");
               else
                  Unit_Name := new String'
                    (Data.Unit_Full_Name.all                    &
                     "."                                        &
                     Current_N_Type.Root_Nesting_Ancestor.all &
                     Test_Unit_Name_Suff                        &
                     "."                                        &
                     Nesting_Difference
                       (Current_N_Type.Nesting.all,
                        Data.Unit_Full_Name.all)                &
                     "."                                        &
                     Current_N_Type.Main_Type_Text_Name.all     &
                     "_Tests");
               end if;

               Separate_Unit_Name := new
                 String'(Unit_Name.all &
                         "."           &
                         Separated_Name.all);

               Separate_File_Name := new
                 String'(Unit_To_File_Name (Separate_Unit_Name.all) & ".adb");

               if not Is_Regular_File
                 (Output_Dir & Directory_Separator & Separate_File_Name.all)
               then

                  Create
                    (Output_File,
                     Out_File,
                     Output_Dir & Directory_Separator &
                     Separate_File_Name.all);

                  S_Put (0, "separate (" & Unit_Name.all & ")");
                  New_Line (Output_File);
                  S_Put (0, "package body " & Separated_Name.all & " is");
                  New_Line (Output_File);
                  if Current_N_Type.No_Default_Discriminant then
                     S_Put
                       (3,
                        "--  Local_"                           &
                        Current_N_Type.Main_Type_Text_Name.all &
                        " : aliased "                          &
                        Locate_Previous_Generic
                          (Current_N_Type.Nesting.all,
                           Data.Package_Data_List)             &
                        "."                                    &
                        Current_N_Type.Main_Type_Text_Name.all &
                        ";");
                     New_Line (Output_File);
                     S_Put
                       (3,
                        "procedure User_Set_Up (T : in out Test_" &
                        Current_N_Type.Main_Type_Text_Name.all    &
                        ") is");
                     New_Line (Output_File);

                     S_Put (3, "begin");
                     New_Line (Output_File);
                     S_Put
                       (6, "--  T.Fixture := Local_"           &
                        Current_N_Type.Main_Type_Text_Name.all &
                        "'Access;");
                     New_Line (Output_File);
                     S_Put
                       (6, "null;");
                     New_Line (Output_File);
                     S_Put (3, "end User_Set_Up;");
                  else
                     S_Put
                       (3,
                        "Local_"                               &
                        Current_N_Type.Main_Type_Text_Name.all &
                        " : aliased "                          &
                        Locate_Previous_Generic
                          (Current_N_Type.Nesting.all,
                           Data.Package_Data_List)             &
                        "."                                    &
                        Current_N_Type.Main_Type_Text_Name.all &
                        ";");
                     New_Line (Output_File);
                     S_Put
                       (3,
                        "procedure User_Set_Up (T : in out Test_" &
                        Current_N_Type.Main_Type_Text_Name.all    &
                        ") is");
                     New_Line (Output_File);

                     S_Put (3, "begin");
                     New_Line (Output_File);
                     S_Put
                       (6, "T.Fixture := Local_"               &
                        Current_N_Type.Main_Type_Text_Name.all &
                        "'Access;");
                     New_Line (Output_File);
                     S_Put (3, "end User_Set_Up;");
                  end if;

                  New_Line (Output_File);
                  New_Line (Output_File);
                  S_Put
                    (3,
                     "procedure User_Tear_Down (T : in out Test_" &
                     Current_N_Type.Main_Type_Text_Name.all       &
                     ") is");
                  New_Line (Output_File);

                  S_Put (3, "begin");
                  New_Line (Output_File);
                  S_Put
                    (6, "null;");
                  New_Line (Output_File);
                  S_Put (3, "end User_Tear_Down;");
                  New_Line (Output_File);
                  S_Put (0, "end " & Separated_Name.all & ";");

                  Close (Output_File);

               end if;

               Free (Separate_Unit_Name);
               Free (Separate_File_Name);
               Free (Separated_Name);

               Next (Type_Cur);
            end if;
         end loop;

      end loop;

      --  Test routine stubs.
      Subp_Cur := Data.Subp_List.First;
      loop
         exit when Subp_Cur = Subp_Data_List.No_Element;

         Current_Subp := Subp_Data_List.Element (Subp_Cur);

         Set_Current_Type (Current_Subp.Corresp_Type);

         if not Current_Subp.Is_Abstract then

            Separated_Name := new String'
              (Current_Subp.Subp_Mangle_Name.all);

            if Current_Subp.Nesting.all = Data.Unit_Full_Name.all then
               if Current_Subp.Corresp_Type = 0 then
                  if Data.Is_Generic then
                     New_Unit_Full_Name :=
                       new String'(Data.Unit_Full_Name.all &
                                   "."                     &
                                   Gen_Test_Unit_Name);
                  else
                     New_Unit_Full_Name :=
                       new String'(Data.Unit_Full_Name.all &
                                   "."                     &
                                   Test_Unit_Name);
                  end if;
               else
                  New_Unit_Full_Name := new String'(Data.Unit_Full_Name.all);
               end if;
            else

               if Current_Subp.Corresp_Type = 0 then
                  New_Unit_Full_Name := new String'
                    (Data.Unit_Full_Name.all & "." &
                     Test_Unit_Name & "."          &
                     Convert_To_Simple_Case_Nesting
                       (Nesting_Difference
                         (Current_Subp.Nesting.all,
                          Data.Unit_Full_Name.all)));

               else
                  Set_Current_Type (Current_Subp.Corresp_Type);

                  if Current_Type.Nesting.all = Data.Unit_Full_Name.all then
                     New_Unit_Full_Name := new String'
                       (Data.Unit_Full_Name.all & "." &
                        Nesting_Difference
                          (Current_Subp.Nesting.all,
                           Data.Unit_Full_Name.all));
                  else
                     if Data.Is_Generic then
                        New_Unit_Full_Name := new String'
                          (Data.Unit_Full_Name.all & "."            &
                           Current_Type.Root_Nesting_Ancestor.all &
                           Gen_Test_Unit_Name_Suff & "."            &
                           Nesting_Difference
                             (Current_Subp.Nesting.all,
                              Data.Unit_Full_Name.all));
                     else
                        New_Unit_Full_Name := new String'
                          (Data.Unit_Full_Name.all & "."            &
                           Current_Type.Root_Nesting_Ancestor.all &
                           Test_Unit_Name_Suff & "."                &
                           Nesting_Difference
                             (Current_Subp.Nesting.all,
                              Data.Unit_Full_Name.all));
                     end if;
                  end if;
               end if;
            end if;

            if Current_Subp.Corresp_Type = 0 then

               Unit_Name := new String'(New_Unit_Full_Name.all);

            else

               if Data.Is_Generic then
                  Unit_Name := new
                    String'(New_Unit_Full_Name.all              &
                            "."                                  &
                            Current_Type.Main_Type_Text_Name.all &
                            Gen_Test_Unit_Name_Suff);
               else
                  Unit_Name := new
                    String'(New_Unit_Full_Name.all              &
                            "."                                  &
                            Current_Type.Main_Type_Text_Name.all &
                            Test_Unit_Name_Suff);
               end if;

            end if;

            Free (New_Unit_Full_Name);

            Separate_Unit_Name := new
              String'(Unit_Name.all &
                      "."           &
                      Separated_Name.all);

            Separate_File_Name :=
              new String'(Unit_To_File_Name (Separate_Unit_Name.all) & ".adb");

            Test_Info.Replace
              (Data.Unit_File_Name.all,
               Test_Info.Element (Data.Unit_File_Name.all) + 1);

            All_Tests_Counter := All_Tests_Counter + 1;

            if not Is_Regular_File (Output_Dir          &
                                    Directory_Separator &
                                    Separate_File_Name.all)
            then

               New_Tests_Counter := New_Tests_Counter + 1;

               Create
                 (Output_File,
                  Out_File,
                  Output_Dir & Directory_Separator & Separate_File_Name.all);

               Print_Comment_Separate
                 (Subp_Data_List.Element (Subp_Cur));
               New_Line (Output_File);
               S_Put (0, "separate (" & Unit_Name.all & ")");
               New_Line (Output_File);

               if not Subp_Data_List.Element (Subp_Cur).Is_Abstract then
                  S_Put
                    (0,
                     "procedure "       &
                     Separated_Name.all &
                     " (T : in out ");

                  if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then
                     S_Put (0, "Test) is");
                  else
--                       Type_Idx :=
--                         Subp_Data_List.Element (Subp_Cur).Corresp_Type;
                     S_Put
                       (0,
                        "Test_"                              &
                        Current_Type.Main_Type_Text_Name.all &
                        ") is");
                  end if;
                  New_Line (Output_File);
                  S_Put (3, "pragma Unreferenced (T);");
                  New_Line (Output_File);

                  if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then

                     Current_Subp := Subp_Data_List.Element (Subp_Cur);
                     case Declaration_Kind (Current_Subp.Subp_Declaration) is
                        when A_Function_Declaration =>
                           S_Put
                             (3,
                              "function " &
                              Current_Subp.Subp_Text_Name.all);

                           declare
                              Params : constant
                                Asis.Parameter_Specification_List :=
                                  Parameter_Profile
                                    (Current_Subp.Subp_Declaration);

                              Result : constant Asis.Element :=
                                Result_Profile (Current_Subp.Subp_Declaration);

                              Result_Image : constant String :=
                                Trim (To_String (Element_Image (Result)),
                                      Both);
                           begin

                              if Params'Length /= 0 then
                                 S_Put (1, "(");
                                 for I in Params'Range loop
                                    S_Put
                                      (0,
                                       Trim
                                         (To_String
                                            (Element_Image (Params (I))),
                                          Both));
                                    if I = Params'Last then
                                       S_Put (0, ")");
                                    else
                                       S_Put (0, "; ");
                                    end if;
                                 end loop;
                              end if;

                              S_Put (1, "return " & Result_Image);
                           end;

                        when A_Procedure_Declaration =>
                           S_Put
                             (3,
                              "procedure " &
                              Current_Subp.Subp_Text_Name.all);

                           declare
                              Params : constant
                                Asis.Parameter_Specification_List :=
                                  Parameter_Profile
                                    (Current_Subp.Subp_Declaration);
                           begin

                              if Params'Length /= 0 then
                                 S_Put (1, "(");
                                 for I in Params'Range loop
                                    S_Put
                                      (0,
                                       Trim
                                         (To_String
                                            (Element_Image (Params (I))),
                                          Both));
                                    if I = Params'Last then
                                       S_Put (0, ")");
                                    else
                                       S_Put (0, "; ");
                                    end if;
                                 end loop;
                              end if;
                           end;

                        when others => null;

                     end case;

                     S_Put
                       (1,
                        "renames "                        &
                        Wrapper_Prefix                    &
                        Current_Subp.Subp_Mangle_Name.all &
                        ";");
                     New_Line (Output_File);
                  end if;

                  S_Put (0, "begin");
                  New_Line (Output_File);
                  S_Put (3, "Assert (False, ""Test not implemented."");");
                  New_Line (Output_File);
                  S_Put (0, "end " & Separated_Name.all & ";");
                  New_Line (Output_File);

               end if;

               Close (Output_File);
            end if;

            Free (Separate_Unit_Name);
            Free (Separate_File_Name);
            Free (Separated_Name);
         end if;

         Subp_Data_List.Next (Subp_Cur);
      end loop;

   end Generate_Stubs;

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

   function Get_Subp_Name (Subp : Asis.Element) return String is
   begin
      --  checking for overloaded operators
      if Defining_Name_Kind (First_Name (Subp)) =
        A_Defining_Operator_Symbol
      then
         return Operator_Image (First_Name (Subp));
      else
         return To_String (Defining_Name_Image (First_Name (Subp)));
      end if;

   end Get_Subp_Name;

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

         Report_Std ("aunitstub: " & 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
                 ("aunitstub: can not process redefinition of System in " &
                    Source_Name);

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

      end;

      return Success;
   end Initialize_Context;

   -------------------
   --  Mangle_Hash  --
   -------------------

   function Mangle_Hash
     (Subp       : Asis.Declaration;
      Tagged_Rec : Asis.Declaration := Asis.Nil_Element) return String
   is
      Subp_Name  : constant String := Get_Subp_Name (Subp);
      --  Could cause problems if we have subps with same name as opreator
      --  images.

      SW_Buff     : String_Access;
      Sign_Image  : String_Access;
      Param       : Asis.Element;
      Root_Ignore : Asis.Element;

      Attr_Flag : Boolean;
      --  Used to add a special marking to subprogram parameters whose types
      --  have'Class and 'Base attributes (same parameter can't have both of
      --  those attributes, so the same marking is used).

      Same_Type_Params : Integer;

      Params : constant Parameter_Specification_List :=
        Parameter_Profile (Subp);
      --  Root level parameters list.

      function Unsubtype (Arg : Asis.Declaration) return Asis.Declaration;
      --  If argumnet is a subtype declaration returns corresponding type
      --  declaration, otherwise returns Arg.

      function Parameter_Image (Param_Input : Asis.Element) return String;
      --  Returns the image of given subprogram parameter.

      function Full_Name_Image (Elem : Asis.Element) return String;
      --  Takes a type declaration as an argument.
      --  Returns the image of the type name with full package name
      --  prefix.

      function Handle_Parameters
        (Params : Parameter_Specification_List;
         Result_Profile : Asis.Element)
         return String;
      --  Returns an image of the types from parameters list and the result
      --  type in case of a function for a given list of parameter
      --  specifications.

      -----------------------
      --  Full_Name_Image  --
      -----------------------
      function Full_Name_Image (Elem : Asis.Element) return String is
         Enclosing : Asis.Element;

         Elem_Full_Image : String_Access :=
           new String'(To_String (Defining_Name_Image (First_Name (Elem))));

         Exch_Buff       : String_Access;
      begin

         Enclosing := Elem;
         loop
            case Declaration_Kind (Enclosing) is
               when A_Package_Declaration         |
                    A_Generic_Package_Declaration =>

                  Exch_Buff :=
                    new String'(To_String (Defining_Name_Image
                      (First_Name (Enclosing))) &
                      "." & Elem_Full_Image.all);
                  Free (Elem_Full_Image);
                  Elem_Full_Image := new String'(Exch_Buff.all);
                  Free (Exch_Buff);

               when others =>
                  null;
            end case;

            Enclosing := Enclosing_Element (Enclosing);
            exit when Is_Nil (Enclosing);

         end loop;

         return Elem_Full_Image.all;

      end Full_Name_Image;

      -------------------------
      --  Handle_Parameters  --
      -------------------------
      function Handle_Parameters
        (Params : Parameter_Specification_List;
         Result_Profile : Asis.Element)
         return String
      is
         Params_Full_Image : String_Access := new String'("");
         Exchange_Buff     : String_Access;

         Param : Asis.Element;

      begin

         for I in Params'Range loop

            Param := Params (I);

            if Params_Full_Image.all = "" then
               Exchange_Buff :=
                 new String'("(" & Params_Full_Image.all &
                             Parameter_Image (Param));
            else
               Exchange_Buff :=
                 new String'(Params_Full_Image.all &
                             ";" & Parameter_Image (Param));
            end if;
            Free (Params_Full_Image);
            Params_Full_Image := new String'(Exchange_Buff.all);
            Free (Exchange_Buff);

         end loop;

         if not Is_Nil (Result_Profile) then

            Attr_Flag := False;

            case Definition_Kind (Result_Profile) is

               when Not_A_Definition =>

                  if
                    Expression_Kind (Result_Profile) = An_Attribute_Reference
                    and then
                      (Attribute_Kind (Result_Profile) = A_Class_Attribute
                       or Attribute_Kind (Result_Profile) = A_Base_Attribute)

                  then
                     Attr_Flag := True;
                     Param := Unsubtype (Corresponding_Name_Declaration
                       (Normalize_Reference (Prefix (Result_Profile))));
                  else
                     Param := Unsubtype (Corresponding_Name_Declaration
                       (Normalize_Reference (Result_Profile)));

                  end if;

                  if Attr_Flag then
                     Exchange_Buff := new String'
                       (Params_Full_Image.all & ")"    &
                        Full_Name_Image (Param) &
                        "'Attr");
                  else
                     Exchange_Buff := new String'
                       (Params_Full_Image.all & ")" &
                        Full_Name_Image (Param));
                  end if;
                  Free (Params_Full_Image);
                  Params_Full_Image := new String'(Exchange_Buff.all);
                  Free (Exchange_Buff);

               when An_Access_Definition =>

                  Param :=
                    Anonymous_Access_To_Object_Subtype_Mark (Result_Profile);

                  if
                    Expression_Kind (Result_Profile) = An_Attribute_Reference
                    and then
                      (Attribute_Kind (Result_Profile) = A_Class_Attribute
                       or Attribute_Kind (Result_Profile) = A_Base_Attribute)
                  then
                     Attr_Flag := True;
                     Param := Unsubtype (Corresponding_Name_Declaration
                       (Normalize_Reference (Prefix (Result_Profile))));
                  else
                     Param := Unsubtype (Corresponding_Name_Declaration
                       (Normalize_Reference (Result_Profile)));

                  end if;

                  if Attr_Flag then
                     Exchange_Buff := new String'
                       (Params_Full_Image.all & ")@" &
                        Full_Name_Image (Result_Profile) &  "'Attr");
                  else
                     Exchange_Buff := new String'
                       (Params_Full_Image.all & ")@" &
                        Full_Name_Image (Result_Profile));
                  end if;
                  Free (Params_Full_Image);
                  Params_Full_Image := new String'(Exchange_Buff.all);
                  Free (Exchange_Buff);

               when others =>
                  null;
            end case;

         else
            Exchange_Buff :=
              new String'(Params_Full_Image.all & ")");
            Free (Params_Full_Image);
            Params_Full_Image := new String'(Exchange_Buff.all);
            Free (Exchange_Buff);
         end if;

         return Params_Full_Image.all;

      end Handle_Parameters;

      -----------------------
      --  Parameter_Image  --
      -----------------------

      function Parameter_Image (Param_Input : Asis.Element) return String is

         Name_List : constant Defining_Name_List := Names (Param_Input);

         Param_Full_Image : constant String_Access := new String'("");

         Param : Asis.Element;
      begin

         Param := Object_Declaration_View (Param_Input);

         case Definition_Kind (Param) is

            when Not_A_Definition =>

               if
                 Expression_Kind (Param) = An_Attribute_Reference
                 and then
                   (Attribute_Kind (Param) = A_Class_Attribute
                    or Attribute_Kind (Param) = A_Base_Attribute)
               then
                  Param := Unsubtype (Corresponding_Name_Declaration
                    (Normalize_Reference (Prefix (Param))));

                  return
                    Trim (Integer'Image (Name_List'Length), Both) &
                    Full_Name_Image (Corresponding_Name_Declaration
                                     (Normalize_Reference (Param))) &
                    "'Attr";
               else
                  return
                    Trim (Integer'Image (Name_List'Length), Both) &
                    Full_Name_Image (Unsubtype (Corresponding_Name_Declaration
                                     (Normalize_Reference (Param))));
               end if;

            when An_Access_Definition =>

               case (Access_Definition_Kind (Param_Input)) is

                  when An_Anonymous_Access_To_Function =>

                     return
                       Trim (Integer'Image (Name_List'Length), Both) &
                       Handle_Parameters
                         (Access_To_Subprogram_Parameter_Profile (Param_Input),
                          Access_To_Function_Result_Profile (Param_Input));

                  when An_Anonymous_Access_To_Procedure =>

                     return
                       Trim (Integer'Image (Name_List'Length), Both) &
                       Handle_Parameters
                         (Access_To_Subprogram_Parameter_Profile (Param_Input),
                          Asis.Nil_Element);

                  when others =>
                     Param := Anonymous_Access_To_Object_Subtype_Mark (Param);

                     if
                       Expression_Kind (Param) = An_Attribute_Reference
                       and then
                         (Attribute_Kind (Param) = A_Class_Attribute
                          or Attribute_Kind (Param) = A_Base_Attribute)
                     then
                        Param := Unsubtype (Corresponding_Name_Declaration
                          (Normalize_Reference (Prefix (Param))));
                        return
                          Trim (Integer'Image (Name_List'Length), Both) & "@" &
                          Full_Name_Image (Param) & "'Attr";
                     else
                        Param := Unsubtype (Corresponding_Name_Declaration
                          (Normalize_Reference ((Param))));
                        return
                          Trim (Integer'Image (Name_List'Length), Both) & "@" &
                          Full_Name_Image (Param);
                     end if;
               end case;

            when others =>
               null;

         end case;

         return Param_Full_Image.all;

      end Parameter_Image;

      function Unsubtype (Arg : Asis.Declaration) return Asis.Declaration
      is
      begin
         if Declaration_Kind (Arg) = A_Subtype_Declaration then
            return Corresponding_First_Subtype (Arg);
         end if;
         return Arg;
      end Unsubtype;

   begin

      case Declaration_Kind (Subp) is
         when A_Function_Declaration          |
              A_Function_Renaming_Declaration =>
            Sign_Image :=
              new String'("function" & Subp_Name & "(");
         when A_Procedure_Declaration        |
            A_Procedure_Renaming_Declaration =>
            Sign_Image :=
              new String'("procedure" & Subp_Name & "(");
         when others =>
            return "";
      end case;

      if Is_Nil (Tagged_Rec) then
         Root_Ignore := Asis.Nil_Element;
      else
         Root_Ignore := Root_Type_Declaration (Tagged_Rec);
      end if;

      for I in Params'Range loop

         Attr_Flag := False;

         Param := Params (I);

         Same_Type_Params := Names (Param)'Length;
         SW_Buff :=
           new String'(Sign_Image.all &
                       Trim (Integer'Image (Same_Type_Params), Both));
         Free (Sign_Image);
         Sign_Image := new String'(SW_Buff.all);
         Free (SW_Buff);

         Param := Object_Declaration_View (Param);

         case Definition_Kind (Param) is

            when Not_A_Definition =>

               if
                 Expression_Kind (Param) = An_Attribute_Reference
                 and then
                   (Attribute_Kind (Param) = A_Class_Attribute
                    or Attribute_Kind (Param) = A_Base_Attribute)
               then
                  Attr_Flag := True;
                  Param := Unsubtype (Corresponding_Name_Declaration
                    (Normalize_Reference (Prefix (Param))));
               else
                  Param := Unsubtype (Corresponding_Name_Declaration
                    (Normalize_Reference (Param)));

                  if not Is_Nil (Root_Ignore) then
                     if
                       Is_Equal
                         (Root_Ignore,
                          Root_Type_Declaration (Param))
                     then
                        Param := Root_Ignore;
                     end if;
                  end if;
               end if;

               if Attr_Flag then
                  SW_Buff := new String'
                    (Sign_Image.all & Full_Name_Image (Param) & "'Attr;");
               else
                  SW_Buff := new String'
                    (Sign_Image.all & Full_Name_Image (Param) & ";");
               end if;
               Free (Sign_Image);
               Sign_Image := new String'(SW_Buff.all);
               Free (SW_Buff);

            when An_Access_Definition =>

               case (Access_Definition_Kind (Param)) is

                  when An_Anonymous_Access_To_Function =>

                     SW_Buff := new String'
                       (Sign_Image.all                                     &
                        Handle_Parameters
                          (Access_To_Subprogram_Parameter_Profile (Param),
                           Access_To_Function_Result_Profile (Param))      &
                        ";");
                     Free (Sign_Image);
                     Sign_Image := new String'(SW_Buff.all);
                     Free (SW_Buff);

                  when An_Anonymous_Access_To_Procedure =>

                     SW_Buff := new String'
                       (Sign_Image.all                                     &
                        Handle_Parameters
                          (Access_To_Subprogram_Parameter_Profile (Param),
                           Asis.Nil_Element)                               &
                        ";");
                     Free (Sign_Image);
                     Sign_Image := new String'(SW_Buff.all);
                     Free (SW_Buff);

                  when others =>

                     Param := Anonymous_Access_To_Object_Subtype_Mark (Param);

                     if
                       Expression_Kind (Param) = An_Attribute_Reference
                       and then
                         (Attribute_Kind (Param) = A_Class_Attribute
                          or Attribute_Kind (Param) = A_Base_Attribute)
                     then
                        Attr_Flag := True;
                        Param := Unsubtype (Corresponding_Name_Declaration
                          (Normalize_Reference (Prefix (Param))));
                     else
                        Param := Unsubtype (Corresponding_Name_Declaration
                          (Normalize_Reference (Param)));

                        if not Is_Nil (Root_Ignore) then
                           if
                             Is_Equal
                               (Root_Ignore,
                                Root_Type_Declaration (Param))
                           then
                              Param := Root_Ignore;
                           end if;
                        end if;
                     end if;

                     if Attr_Flag then
                        SW_Buff := new String'
                          (Sign_Image.all & "@" &
                           Full_Name_Image (Param) &  "'Attr;");
                     else
                        SW_Buff := new String'
                          (Sign_Image.all & "@" &
                           Full_Name_Image (Param) & ";");
                     end if;
                     Free (Sign_Image);
                     Sign_Image := new String'(SW_Buff.all);
                     Free (SW_Buff);

               end case;

            when others =>
               null;

         end case;

      end loop;

      if
        Declaration_Kind (Subp) = A_Function_Declaration or else
        Declaration_Kind (Subp) = A_Function_Renaming_Declaration
      then

         Attr_Flag := False;

         Param := Result_Profile (Subp);

         case Definition_Kind (Param) is

            when Not_A_Definition =>

               if
                 Expression_Kind (Param) = An_Attribute_Reference
                 and then
                   (Attribute_Kind (Param) = A_Class_Attribute
                    or Attribute_Kind (Param) = A_Base_Attribute)
               then
                  Attr_Flag := True;
                  Param := Unsubtype (Corresponding_Name_Declaration
                    (Normalize_Reference (Prefix (Param))));
               else
                  Param := Unsubtype (Corresponding_Name_Declaration
                    (Normalize_Reference (Param)));

                  if not Is_Nil (Root_Ignore) then
                     if
                       Is_Equal
                         (Root_Ignore,
                          Root_Type_Declaration (Param))
                     then
                        Param := Root_Ignore;
                     end if;
                  end if;
               end if;

               if Attr_Flag then
                  SW_Buff := new String'
                    (Sign_Image.all & ")"    &
                     Full_Name_Image (Param) &
                     "'Attr;");
               else
                  SW_Buff := new String'
                    (Sign_Image.all & ")" & Full_Name_Image (Param) & ";");
               end if;
               Free (Sign_Image);
               Sign_Image := new String'(SW_Buff.all);
               Free (SW_Buff);

            when An_Access_Definition =>
               Param := Anonymous_Access_To_Object_Subtype_Mark (Param);

               if
                 Expression_Kind (Param) = An_Attribute_Reference
                 and then
                   (Attribute_Kind (Param) = A_Class_Attribute
                    or Attribute_Kind (Param) = A_Base_Attribute)
               then
                  Attr_Flag := True;
                  Param := Unsubtype (Corresponding_Name_Declaration
                    (Normalize_Reference (Prefix (Param))));
               else
                  Param := Unsubtype (Corresponding_Name_Declaration
                    (Normalize_Reference (Param)));

                  if not Is_Nil (Root_Ignore) then
                     if
                       Is_Equal
                         (Root_Ignore,
                          Root_Type_Declaration (Param))
                     then
                        Param := Root_Ignore;
                     end if;
                  end if;
               end if;

               if Attr_Flag then
                  SW_Buff := new String'
                    (Sign_Image.all & ")@" &
                     Full_Name_Image (Param) &  "'Attr;");
               else
                  SW_Buff := new String'
                    (Sign_Image.all & ")@" & Full_Name_Image (Param) & ";");
               end if;
               Free (Sign_Image);
               Sign_Image := new String'(SW_Buff.all);
               Free (SW_Buff);

            when others =>
               null;
         end case;

      else
         SW_Buff := new
           String'(Sign_Image.all & ")");
         Free (Sign_Image);
         Sign_Image := new String'(SW_Buff.all);
         Free (SW_Buff);
      end if;

      SW_Buff := new String'(GNAT.SHA1.Digest (Sign_Image.all));

      return
        Test_Routine_Prefix &
        Subp_Name & "_"     &
        SW_Buff.all (SW_Buff'First .. SW_Buff'First + 5);

   end Mangle_Hash;

   ----------------------
   --  Operator_Image  --
   ----------------------

   function Operator_Image (Op : Defining_Name) return String is
   begin
      case Operator_Kind (Op) is

         when An_And_Operator =>                   -- and
            return "And";
         when An_Or_Operator =>                    -- or
            return "Or";
         when An_Xor_Operator =>                   -- xor
            return "Xor";
         when An_Equal_Operator =>                 -- =
            return "Equal";
         when A_Not_Equal_Operator =>              -- /=
            return "Not_Equal";
         when A_Less_Than_Operator =>              -- <
            return "Less_Than";
         when A_Less_Than_Or_Equal_Operator =>     -- <=
            return "Less_Than_Or_Equal";
         when A_Greater_Than_Operator =>           -- >
            return "Greater_Than";
         when A_Greater_Than_Or_Equal_Operator =>  -- >=
            return "Greater_Than_Or_Equal";
         when A_Plus_Operator =>                   -- +
            return "Plus";
         when A_Minus_Operator =>                  -- -
            return "Minus";
         when A_Concatenate_Operator =>            -- &
            return "Concatenate";
         when A_Unary_Plus_Operator =>             -- +
            return "Unary_Plus";
         when A_Unary_Minus_Operator =>            -- -
            return "Unary_Minus";
         when A_Multiply_Operator =>               -- *
            return "Multiply";
         when A_Divide_Operator =>                 -- /
            return "Devide";
         when A_Mod_Operator =>                    -- mod
            return "Mod";
         when A_Rem_Operator =>                    -- rem
            return "Rem";
         when An_Exponentiate_Operator =>          -- **
            return "Exponentiate";
         when An_Abs_Operator =>                   -- abs
            return "Abs";
         when A_Not_Operator =>                    -- not
            return "Not";

         when others =>
            raise Fatal_Error;
      end case;

   end Operator_Image;

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

      if Declaration_Kind (Dec_Elem) = A_Subtype_Declaration then
         return Corresponding_First_Subtype (Dec_Elem);
      end if;

      return Dec_Elem;

   exception

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

   end Parent_Type_Declaration;

   -------------------------------
   -- Print_Comment_Declaration --
   -------------------------------

   procedure Print_Comment_Declaration (Subp : Subp_Info; Span : Natural := 0)
   is
      File_Name : constant String    := Base_Name (To_String (Text_Name
        (Enclosing_Compilation_Unit (Subp.Subp_Declaration))));

      Elem_Span : constant Asis.Text.Span :=
        Element_Span (Subp.Subp_Declaration);
   begin
      S_Put
        (Span,
         "--  " &
         File_Name &
         ":" &
         Trim (Integer'Image (Elem_Span.First_Line), Both) &
         ":" &
         Trim (Integer'Image (Elem_Span.First_Column), Both) &
         ":" &
         Subp.Subp_Text_Name.all);
      if Subp.Has_TC_Info then
         S_Put (0, ":" & Subp.TC_Info.Name.all);
      end if;
      New_Line (Output_File);
   end Print_Comment_Declaration;

   ----------------------------
   -- Print_Comment_Separate --
   ----------------------------

   procedure Print_Comment_Separate (Subp : Subp_Info; Span : Natural := 0) is
      Image : constant Line_List := Lines (Subp.Subp_Declaration);
   begin
      for I in Image'Range loop
         S_Put
           (Span,
            "--  " &
            Trim (To_String (Line_Image (Image (I))), Both));
         New_Line (Output_File);
         if Subp.Has_TC_Info then
            S_Put (Span, "--  Test Case """ & Subp.TC_Info.Name.all & """");
            New_Line (Output_File);
         end if;
      end loop;
   end Print_Comment_Separate;

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

   procedure Process_Source (The_Unit : Asis.Compilation_Unit) is
      Source_Name : String_Access;
      Data        : Data_Holder;

      Apropriate_Source : Boolean;
   begin

      Source_Name :=
        new String'(Base_Name (To_String (Text_Name (The_Unit))));
      Gather_Data (The_Unit, Data, Apropriate_Source);

      if Apropriate_Source then
         if Data.Data_Kind = Declaration_Data then
            Generate_Test_Package (Data);
            Generate_Stubs (Data);
         end if;
         if Data.Data_Kind = Instantiation then
            Generate_Test_Package_Instantiation (Data);
         end if;
         Set_Source_Status (Source_Name.all, Processed);
      end if;

      if Data.Data_Kind = Declaration_Data then
         Clear (Data.Type_Data_List);
         Clear (Data.Nested_Type_Data_List);
         Clear (Data.Subp_List);
         Clear (Data.Package_Data_List);
      end if;

   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;

      Cur : Tests_Per_Unit.Cursor;

   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;

      Generate_Project_File;

      Cur := Test_Info.First;
      loop
         exit when Cur = Tests_Per_Unit.No_Element;

         Report_Std
           (Natural'Image (Tests_Per_Unit.Element (Cur)) &
            " testable subprograms in " &
            Tests_Per_Unit.Key (Cur));

         Tests_Per_Unit.Next (Cur);
      end loop;

      Test_Info.Clear;
      Report_Std
        ("aunitstub:" &
         Natural'Image (All_Tests_Counter) &
         " testable subprogram(s) processed");
      Report_Std
        ("aunitstub:" &
         Natural'Image (New_Tests_Counter) &
         " new stub(s) generated");

   end Process_Sources;

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

         if Declaration_Kind (Dec_Elem) = A_Subtype_Declaration then
            Dec_Elem := Corresponding_First_Subtype (Dec_Elem);
         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
            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 ("aunitstub: cannot delete " &
                     Last_Context_Name.all & ".adt");
      end if;

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

      Free (Last_Context_Name);
   end Source_Clean_Up;

   -------------------------
   --  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 AUnitStub.Stub_Generator;
