------------------------------------------------------------------------------
--                                                                          --
--                           GNATSTUB COMPONENTS                            --
--                                                                          --
--                      G N A T S T U B . S A M P L E R                     --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--           Copyright (C) 1997-2009, Free Software Foundation, Inc.        --
--                                                                          --
-- Gnatstub 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. Gnatstub is distributed  in the hope  that it will be useful,   --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MER-      --
-- CHANTABILITY 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.                                       --
--                                                                          --
-- Gnatstub is distributed as a part of the ASIS implementation for GNAT    --
-- (ASIS-for-GNAT).                                                         --
--                                                                          --
-- Gnatstub  was  originally  developed  by  Alexei Kuchumov  as a part of  --
-- collaboration  between  Software  Engineering  Laboratory of  the Swiss  --
-- Federal  Institute  of  Technology  in  Lausanne, Switzerland, and  the  --
-- Scientific  Research  Computer  Center  of the  Moscow State University, --
-- Russia.  This  work  was  supported  by  a grant from the Swiss National --
-- Science Foundation,  no 7SUPJ048247, funding a project  "Development of  --
-- ASIS for GNAT with industry quality".                                    --
--                                                                          --
-- Gnatstub is now maintained by AdaCore (http://www.adacore.com).          --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling;    use Ada.Characters.Handling;
with GNAT.Directory_Operations;
with Ada.Exceptions;             use Ada.Exceptions;
with Ada.IO_Exceptions;
with Ada.Strings;                use Ada.Strings;
with Ada.Strings.Fixed;          use Ada.Strings.Fixed;
with Ada.Text_IO;                use Ada.Text_IO;

with GNAT.Command_Line;          use GNAT.Command_Line;
with GNAT.OS_Lib;                use GNAT.OS_Lib;

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

with Gnatvsn;
with Hostparm;

with ASIS_UL.Common;             use ASIS_UL.Common;
with ASIS_UL.Compiler_Options;   use ASIS_UL.Compiler_Options;
with ASIS_UL.Misc;               use ASIS_UL.Misc;
with ASIS_UL.Options;            use ASIS_UL.Options;
with ASIS_UL.Utilities;          use ASIS_UL.Utilities;

with Gnatstub.Options;           use Gnatstub.Options;

package body Gnatstub.Sampler is

   use type Asis.Errors.Error_Kinds;

   My_Context : Asis.Context;

   Level       : Integer := 0;
   --  nesting level of a spec being processed

   Body_File   : File_Type;
   Tree_File   : File_Type;
   Spec_File   : File_Type;
   Form        : constant String := "";

   ------------------------------------
   -- The note about pretty-printing --
   ------------------------------------

   --  We do not put any special efforts in getting a very nice formatting of
   --  the sample body code generated by gnatstub. This code is supposed to be
   --  revised manually by a gnatstub user, so only some very general elements
   --  of pretty-printing are implemented in gnatstub

   -----------------------
   -- Local subprograms --
   -----------------------

   function Get_Tree_Name return String;
   --  Computes the name of the tree file from Short_File_Name.

   procedure Scan_Gnatstub_Arguments;
   --  Scans gnatstub arguments and checks that at least the name of the spec
   --  to create the body for is provided.

   procedure Check_Parameters;
   --  Checks, that Gnatstub options and files existing in the file
   --  system fit each other. If the check fails, generates the diagnostic
   --  message and raises Parameter_Error

   procedure Prepare_Context;
   --  If in NON-GNSA mode, this procedure creates a tree file or checks if the
   --  tree file already exists, depending on options. Then it defines and
   --  opens the ASIS Context.
   --  In GNSA mode, it defines and opens the ASIS GNSA Context

   type Element_Node;
   type Link is access all Element_Node;

   type Element_Node is record
      Spec      : Asis.Element := Nil_Element;
      Spec_Name : String_Access;
      --  not used for incomplete type declarations
      Up        : Link;
      Down      : Link;
      Prev      : Link;
      Next      : Link;
      Last      : Link;
   end record;
   --  An element of a dynamic structure representing a "skeleton" of the body
   --  to be generated
   --
   --  Logically this structure is a list of elements representing local
   --  bodies and sublists representing the bodies which are a components of
   --  some local body. Each list and sublist is represented by its first
   --  element. For this first list element, the field Last is used to point
   --  to the last element in this list to speed up adding the new element if
   --  we do not have to order alphabetically the local bodies.

   Body_Structure : aliased Element_Node;
   --  this is a "design" for a body to generate. It contains references
   --  to the elements from the argument spec for which body samples should
   --  be generated, ordered alphabetically. The top of this link structure
   --  is the Element representing a unit declaration from the argument
   --  compilation unit.

   -------------------------------------------------
   --  Actuals for Traverse_Element instantiation --
   -------------------------------------------------

   type Body_State is record
      Argument_Spec : Boolean := True;
      --  flag indicating if we are in the very beginning (very top)
      --  of scanning the argument library unit declaration
      Current_List : Link;
      --  declaration list in which a currently processed spec
      --  should be inserted;
      Last_Top : Link;
      --  an element which represents a declaration from which the currently
      --  processed sublist was originated
      New_List_Needed : Boolean := False;
      --  flag indication if a new sublist should be created
   end record;

   procedure Create_Element_Node
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Body_State);
   --  when visiting an Element representing something for which a body
   --  sample may be required, we check if the body is really required
   --  and insert the corresponding Element on the right place in Body_State
   --  if it is.

   procedure Go_Up
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Body_State);
   --  when leaving a [generic] package declaration or a protected [type]
   --  declaration, we have to go one step up in Body_State structure.

   procedure Create_Body_Structure is new Traverse_Element
     (State_Information => Body_State,
      Pre_Operation     => Create_Element_Node,
      Post_Operation    => Go_Up);
   --  Creates Body_Structure by traversing an argument spec and choosing
   --  specs to create body samples for

   function Requires_Body (El : Element) return Boolean;
   --  checks if a body sample should be created for an element

   function Name (El : Asis.Element) return String;
   --  returns a defining name string image for a declaration which
   --  defines exactly one name. This should definitely be made an extension
   --  query

   function Bodyless_Package (Node : Link) return Boolean;
   --  Checks if Node represents a local package which does not require
   --  a body. (It is an error to call this function for a null
   --  argument

   procedure Generate_CU_Header (Success   : out Boolean);
   --  Generates in Body_File the comment header for the sample body. Sets
   --  Success to True if the comment header is successfully generated

   procedure Generate_Unit_Header (Node : Link);
   --  Generates the comment header for a local program unit body. Does nothing
   --  if No_Local_Comment_Headers is ON.

   procedure Generate_Body_Structure;
   --  generates in Body_File the Ada part of the sample body, using
   --  the list structure created in Body_Structure as a template

   --  The following group of subprograms generate completion for specific
   --  kinds of specs:

   procedure Generate_Package_Body (Node : Link);

   procedure Generate_Function_Body (Node : Link);

   procedure Generate_Procedure_Body (Node : Link);

   procedure Generate_Entry_Body (Node : Link);

   procedure Generate_Protected_Body (Node : Link);

   procedure Generate_Task_Body (Node : Link);

   procedure Generate_Full_Type_Declaration (Node : Link);

   procedure Generate_Profile (Node : Link; Change_Line : out Boolean);
   --  Generates an entry_body_formal_part, parameter or parameter and result
   --  profile for the body of a program unit represented by Node. Upon exit,
   --  sets Change_Line is set True  if the following "is" for the body should
   --  be generated on a new line;

   function Image_For_String (S : String) return String;
   --  If S starts and ends with '"', return '"' & S & '"", otherwise return S.
   --  This is needed to create an image of an operator symbol in generated
   --  string constants.

   procedure Emergency_Clean_Up;
   --  Does clean up actions in case if an exception was raised during
   --  creating a body sample (closes a Context, dissociates it, finalizes
   --  ASIS, closes and deletes needed files.

   function Allows_Var_Declaration
     (Res_Profile : Asis.Element)
      return        Boolean;
   --  This function assumes that Res_Profile represents the result profile
   --  from a function specification, it checks if this profile denotes a type
   --  that allow creating a local object of this type (to return as the
   --  function result in the function body stub).

   ----------------------------
   -- Allows_Var_Declaration --
   ----------------------------

   function Allows_Var_Declaration
     (Res_Profile : Asis.Element)
      return        Boolean
   is
      Tmp    : Asis.Element;
      Result : Boolean := False;
   begin

      if Element_Kind (Res_Profile) = An_Expression then
         --  Definitely False for functions returning anonymous access
         --  definitions

         if Attribute_Kind (Res_Profile) = A_Base_Attribute then
            Result := True;
         else
            Tmp    := Normalize_Reference (Res_Profile);
            Result := Can_Create_Return_Object (Tmp);
         end if;

      end if;

      return Result;
   end Allows_Var_Declaration;

   ----------------------
   -- Bodyless_Package --
   ----------------------

   function Bodyless_Package (Node : Link) return Boolean is
      Result    : Boolean                     := False;
      Arg_Kind  : constant Flat_Element_Kinds := Flat_Element_Kind (Node.Spec);
      Next_Node : Link;
      Next_List : Link;
   begin
      if Arg_Kind = A_Package_Declaration or else
         Arg_Kind = A_Generic_Package_Declaration
      then
         Result := True;

         if Node.Down /= null then

            Next_List := Node.Down;

            while Next_List.Prev /= null loop
               Next_List := Next_List.Prev;
            end loop;

            Next_Node := Next_List;

            while Next_Node /= null loop

               if not Bodyless_Package (Next_Node) then
                  Result := False;
                  exit;
               end if;

               Next_Node := Next_Node.Next;
            end loop;

         end if;

      end if;

      return Result;

   end Bodyless_Package;

   ----------------
   -- Brief_Help --
   ----------------

   procedure Brief_Help is
      Tmp_Output : constant File_Access := Current_Output;
   begin
      Set_Output (Standard_Error);

      Put_Line ("Usage: gnatstub [opts] filename [directory] [gcc_switches]");
      Put_Line ("");
      Put_Line ("  filename  source file");
      Put      ("  directory directory to place a sample body");
      Put_Line (" (default is the current directory)");
      Put_Line ("");
      Put_Line ("gnatstub options:");
      Put_Line ("");
      Put      ("  -f                     replace an existing body file ");
      Put_Line ("(if any)");
      Put_Line ("                         with a body sample");

      Put      ("  -gnatec<path>          use additional configuration ");
      Put_Line ("file,");
      Put_Line ("                         same meaning as for gcc");

      Put_Line ("  -gnatyMnnn             maximum line length in " &
                "a sample body");

      Put      ("  -gnatyn                (n in 1 .. 9) number of spaces ");
      Put_Line ("used for indentation in");
      Put_Line ("                         a sample body");

      Put_Line ("  -gnatyo                alphabetically order local bodies");

      Put_Line ("  -hg                    insert a sample comment header");
      Put_Line ("  -hs                    insert the comment header " &
                "from the spec");

      Put      ("  --header-file=filename insert the comment header from ");
      Put_Line ("the specified file");

      Put_Line ("  -Idir                  source search dir, has the same " &
                "meaning as for");
      Put_Line ("                         gcc and gnatmake");
      Put      ("  -I-                    do not look for the sources ");
      Put_Line ("in the default directory");

      Put_Line ("  -in                    same as -gnatyn");
      Put_Line ("  -k                     do not remove the tree file");
      Put_Line ("  -lnnn                  same as -gnatMnnn");

      Put_Line ("  --no-exception         avoid raising Program_Error " &
                "in stubs");

      Put_Line ("  --no-local-header      no local comment headers for " &
                "unit stubs");

      Put      ("  -o body-name           the name of the file to place ");
      Put_Line ("the body into.");
      Put_Line ("                         This parameter has to be set if " &
               "the argument file");
      Put_Line ("                         does not follow the GNAT " &
                "file name rules");

      Put_Line ("  -q                     quiet mode");
      Put      ("  -r                     reuse the tree file (if any) ");
      Put_Line ("instead of creating it");
      Put_Line ("                         (-r also implies -k)");

      Put_Line ("  -t                     overwrite the existing tree file");

      Put_Line ("  -v                     verbose mode");

      Put      ("  gcc_switches           '-cargs switches' where 'switches'");
      Put_Line (" is a list");
      Put_Line ("                         of valid gcc switches");

      Set_Output (Tmp_Output.all);
   end Brief_Help;

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

   procedure Check_Parameters is
      Str_Tmp : String_Access;
   begin

      --  Check that if the argument file does not follow the GNAT file name
      --  conventions, then the output file name is provided:
      File_Name_Len   := File_Name'Length;
      File_Name_First := File_Name'First;
      File_Name_Last  := File_Name'Last;

      if not (File_Name_Len  >= 5 and then
              File_Name (File_Name_Last - 3 .. File_Name_Last) = ".ads")
        and then
         Body_Name = null
      then

         if File_Name_Len  >= 5 and then
            File_Name (File_Name_Last - 3 .. File_Name_Last) = ".adb"
         then
            --  A special case: the argument file looks like a body file
            Put      (Standard_Error, "gnatstub: input file looks like ");
            Put_Line (Standard_Error, "a body!");
         end if;

         --  The general case
         Put      (Standard_Error, "gnatstub: output file name should be ");
         Put_Line (Standard_Error, "provided because");
         Put      (Standard_Error, "          " & File_Name.all & " does ");
         Put      (Standard_Error, "not follow GNAT naming rules for ");
         Put_Line (Standard_Error, "spec files");

         raise Parameter_Error;
      end if;

      --  checking if the file to process really exists:
      if not Is_Regular_File (File_Name.all) then
         Put_Line (Standard_Error, "gnatstub: cannot find " & File_Name.all);
         raise Parameter_Error;
      end if;

      --  if destination is set, check if the destination directory exists:
      if Destination_Dir.all /= "" and then
         not Is_Directory (Destination_Dir.all)
      then
         Put_Line (Standard_Error, "gnatstub: directory " & Destination_Dir.all
                 & " does not exist");
         raise Parameter_Error;
      end if;

      --  Compute the body file name if it is not set or check that it does
      --  not contain the directory info otherwise

      Short_File_Name :=
        new String'(GNAT.Directory_Operations.Base_Name (File_Name.all));
      Short_File_Name_Len   := Short_File_Name'Length;
      Short_File_Name_First := Short_File_Name'First;
      Short_File_Name_Last  := Short_File_Name'Last;

      if Body_Name = null then

         if Destination_Dir.all = "" then
            Body_Name := new String'(Short_File_Name.all);
         else
            Body_Name := new String'
                            (Destination_Dir.all &
                             Directory_Separator &
                             Short_File_Name.all);
         end if;

         Body_Name (Body_Name'Last) := 'b';

      else

         if GNAT.Directory_Operations.Base_Name (Body_Name.all) /=
            Body_Name.all
         then
            Put      (Standard_Error, "gnatstub: output file name should ");
            Put_Line (Standard_Error, "not contain any path information");
            raise Parameter_Error;
         end if;

         if Destination_Dir.all /= "" then
            Str_Tmp := new String'(Destination_Dir.all &
                                         Directory_Separator &
                                         Body_Name.all);
            Free (Body_Name);
            Body_Name := new String'(Str_Tmp.all);
            Free (Str_Tmp);
         end if;

      end if;

      Full_Body_Name :=
      --  new String'(Str_Tmp.all);
        new String'(GNAT.Directory_Operations.Format_Pathname
                      (Normalize_Pathname (Body_Name.all)));

      --  Normalizing the argument name

      Str_Tmp :=
        new String'(GNAT.Directory_Operations.Format_Pathname
                      (Normalize_Pathname (File_Name.all)));

      Full_File_Name := new String'(Str_Tmp.all);
      Free (Str_Tmp);

      --  Check if the source and the destination are not the same

      if Full_File_Name.all = Full_Body_Name.all then
         Put (Standard_Error, "gnatstub: output file is the same as the ");
         Put (Standard_Error, "argument file - check the file names");

         New_Line (Standard_Error);
         raise Parameter_Error;
      end if;

      --  checking if a body already exists:

      if Is_Regular_File (Body_Name.all) then

         if Overwrite_Body then

            if Is_Writable_File (Body_Name.all) then

               begin
                  Open (Body_File, Out_File, Body_Name.all, Form);
                  Delete (Body_File);
               exception
                  when others =>
                     Put_Line
                       (Standard_Error,
                       "gnatstub: cannot delete the existing body for " &
                       File_Name.all);
                     Put_Line
                       (Standard_Error,
                       "          the body file may be in use by " &
                       "another process");

                     raise Parameter_Error;
               end;
            else
               Put_Line
                 (Standard_Error,
                 "gnatstub: the existing body for " & File_Name.all
                 & " cannot be overwritten");
               Put_Line
                 (Standard_Error,
                 "          check file access permissions");
               raise Parameter_Error;
            end if;
         else
            Put_Line (Standard_Error, "gnatstub: the body for " & File_Name.all
                   & " already exists");
            Put_Line (Standard_Error, "          use -f to overwrite it");
            raise Parameter_Error;
         end if;

      end if;

      --  Check that the comment header file exists:

      if Header = From_File
       and then
         not Is_Regular_File (Header_File_Name.all) then
            Put_Line
              (Standard_Error,
               "gnatstub: the file " & Header_File_Name.all &
               " to take the comment header from does not exists");
            raise Parameter_Error;
      end if;

      --  now, checking the situation with the tree file:
      Tree_Name := new String'(Get_Tree_Name);

      if Is_Regular_File (Tree_Name.all) then
         Tree_Exists := True;

         if not (Reuse_Tree or else Overwrite_Tree) then
            Put      (Standard_Error, "gnatstub: " & Tree_Name.all);
            Put_Line (Standard_Error, " already exists");
            Put      (Standard_Error, "           use -r or -t to reuse or ");
            Put_Line (Standard_Error, "to overwrite it");
            raise Parameter_Error;
         end if;

      else

         if Reuse_Tree then
            Put_Line (Standard_Error, "gnatstub: cannot find " & Tree_Name.all
                   & " (-r is set)");
            raise Parameter_Error;
         end if;

      end if;

      if Reuse_Tree then
         Delete_Tree := False;
         Overwrite_Tree := False;
      end if;

      Set_Arg_List;

      Free (Destination_Dir);

   end Check_Parameters;

   --------------
   -- Clean_Up --
   --------------

   procedure Clean_Up is
   begin

      if Delete_Tree and then Tree_Exists then
         --  Deleting the tree file itself
         Open (Tree_File, In_File, Tree_Name.all, Form);
         Delete (Tree_File);

         --  Deleting the ALI file which was created along with the tree file
         --  We use the modified Tree_Name for this, because we do not need
         --  Tree_Name any more
         Tree_Name (Tree_Name'Last - 2 .. Tree_Name'Last) := "ali";

         if Is_Regular_File (Tree_Name.all) then
            Open (Tree_File, In_File, Tree_Name.all, Form);
            Delete (Tree_File);
         end if;

      end if;

   end Clean_Up;

   -------------------------
   -- Create_Element_Node --
   -------------------------

   procedure Create_Element_Node
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Body_State)
   is
      Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Element);

      Current_Node : Link;

      procedure Insert_In_List
        (State    : in out Body_State;
         El       : Asis.Element;
         New_Node : out Link);
      --  inserts an argument Element in the current list, keeping the
      --  alphabetic ordering. Creates a new sublist if needed.
      --  New_Node returns the reference to the newly inserted node

      --------------------
      -- Insert_In_List --
      --------------------

      procedure Insert_In_List
        (State    : in out Body_State;
         El       :        Asis.Element;
         New_Node :    out Link)
      is
         Next_Node    : Link;
         Insert_After : Link;

         Insert_First : Boolean := False;
         Insert_Last  : Boolean := False;
      begin
         New_Node      := new Element_Node;
         New_Node.Spec := El;

         New_Node.Spec_Name := new String'(Name (El));

         if State.New_List_Needed then
            --  here we have to set up a new sub-list:
            State.Current_List    := New_Node;
            New_Node.Up           := State.Last_Top;
            State.Last_Top.Down   := New_Node;
            State.New_List_Needed := False;

            New_Node.Last := New_Node;
            --  We've just created a new list. It contains a single element
            --  which is its last Element, so we are setting the link to the
            --  last element to the Prev field of the list head element
         else
            --  here we have to insert New_Node in an existing list,
            --  keeping the alphabetical order of program unit names

            New_Node.Up := State.Current_List.Up;

            if Arg_Kind in An_Incomplete_Type_Declaration ..
                 A_Tagged_Incomplete_Type_Declaration
            then
               --  no need for alphabetical ordering, inserting in the
               --  very beginning:

               New_Node.Last := State.Current_List.Last;
               --  New_Node will be the head element of the list, so we have
               --  to copy into this new head element the reference to the
               --  last element of the list.

               New_Node.Next           := State.Current_List;
               State.Current_List.Prev := New_Node;
               State.Current_List      := New_Node;
            else

               if Alphabetical_Ordering then

                  Next_Node := State.Current_List;

                  --  finding the right place in the current list
                  loop

                     if Flat_Element_Kind (Next_Node.Spec) in
                       An_Incomplete_Type_Declaration  ..
                       A_Tagged_Incomplete_Type_Declaration
                     then

                        if Next_Node.Next = null then
                           --  nothing except incomplete types in the list:
                           Insert_After := Next_Node;
                           exit;
                        end if;

                     else
                        --  here we have a program unit spec
                        if To_Lower (New_Node.Spec_Name.all) <
                           To_Lower (Next_Node.Spec_Name.all)
                        then

                           if Next_Node.Prev = null then
                              Insert_First := True;
                           else
                              Insert_After := Next_Node.Prev;
                           end if;

                           exit;
                        end if;

                     end if;

                     if Next_Node.Next = null then
                        Insert_After := Next_Node;
                        Insert_Last  := True;
                        exit;
                     else
                        Next_Node := Next_Node.Next;
                     end if;

                  end loop;

               else
                  Insert_After := State.Current_List.Last;
                  Insert_Last  := True;
               end if;

               --  inserting in the list:
               if Insert_First then
                  --  inserting in the beginning:
                  New_Node.Next           := State.Current_List;
                  State.Current_List.Prev := New_Node;
                  State.Current_List      := New_Node;
               elsif Insert_Last then
                  New_Node.Prev           := Insert_After;
                  Insert_After.Next       := New_Node;
                  State.Current_List.Last := New_Node;
               else
                  New_Node.Next          := Insert_After.Next;
                  Insert_After.Next.Prev := New_Node;
                  New_Node.Prev          := Insert_After;
                  Insert_After.Next      := New_Node;
               end if;

            end if;

         end if;

      end Insert_In_List;

   --  start of the processing of Create_Element_Node
   begin

      if State.Argument_Spec then
         Body_Structure.Spec      := Element;
         State.Argument_Spec      := False;
         Body_Structure.Spec_Name := new String'(Name (Element));
         Current_Node             := Body_Structure'Access;

      elsif Arg_Kind = A_Defining_Identifier then
         --  skipping a defining name of a spec which may contain local
         --  specs requiring bodies
         null;
      elsif Arg_Kind = A_Protected_Definition then
         --  we just have to go one level down to process protected items:
         null;
      elsif not Requires_Body (Element) then
         Control := Abandon_Children;
         return;

      else
         Insert_In_List (State, Element, Current_Node);
      end if;

      if Arg_Kind = A_Package_Declaration          or else
         Arg_Kind = A_Generic_Package_Declaration  or else
         Arg_Kind = A_Single_Protected_Declaration or else
         Arg_Kind = A_Protected_Type_Declaration
      then
         --  here we may have specs requiring bodies inside a construct
         State.New_List_Needed := True;
         State.Last_Top        := Current_Node;
      elsif Arg_Kind = A_Protected_Definition then
         --  we have to skip this syntax level
         null;
      else
         --  no need to go deeper
         Control := Abandon_Children;
      end if;

   end Create_Element_Node;

   -------------------
   -- Create_Sample --
   -------------------

   procedure Create_Sample is
      CU         : Asis.Compilation_Unit;
      CU_Kind    : Unit_Kinds;

      My_Control     : Traverse_Control := Continue;
      My_State       : Body_State;
      Header_Created : Boolean;

   begin

      CU := Main_Unit_In_Current_Tree (My_Context);

      CU_Kind := Unit_Kind (CU);

      if Is_Nil (CU) then
         Put      (Standard_Error, "file " & Gnatstub.Options.File_Name.all);
         Put      (Standard_Error, " does not contain a unit to create ");
         Put_Line (Standard_Error, "a body for");
         return;

      elsif not (CU_Kind in A_Subprogram_Declaration   or else
                 CU_Kind in A_Generic_Unit_Declaration or else
                 CU_Kind =  A_Package)
      then
         Put      (Standard_Error, "Compilation unit " &
                                    To_String (Unit_Full_Name (CU)));
         Put_Line (Standard_Error, " cannot have a body");

         if not Quiet_Mode then
            Put_Line (Standard_Error, "  Unit Kind: " & (CU_Kind'Img));
         end if;

         return;

      elsif not Asis.Extensions.CU_Requires_Body (CU) then
         Put      (Standard_Error, "Compilation unit " &
                                   To_String (Unit_Full_Name (CU)));
         Put_Line (Standard_Error, " does not require a body");

         return;

      else
         --  and here we have to do the job:

         begin
            Create (Body_File, Out_File, Body_Name.all, Form);
         exception
            when Ada.IO_Exceptions.Name_Error =>
               Put_Line (Standard_Error, "gnatstub: cannot create "
                     & "check the file name");
               raise Fatal_Error;
         end;

         Create_Body_Structure (
            Element => Unit_Declaration (CU),
            Control => My_Control,
            State   => My_State);

         --  first, trying to create the header, if needed:
         Generate_CU_Header (Header_Created);

         if Header_Created then
            Generate_Body_Structure;
            Close (Body_File);

            if not Quiet_Mode then
               Put      (Standard_Error, "body is created for ");
               Put_Line (Standard_Error, Gnatstub.Options.File_Name.all);
            end if;

         else
            Put      (Standard_Error, "gnatstub: failed to write the ");
            Put_Line (Standard_Error, "comment header for the body for " &
                                       Gnatstub.Options.File_Name.all);
         end if;

      end if;

      Close (My_Context);
      Dissociate (My_Context);
      Finalize;

   exception

      when Ex : Asis.Exceptions.ASIS_Inappropriate_Context
             |  Asis.Exceptions.ASIS_Inappropriate_Container
             |  Asis.Exceptions.ASIS_Inappropriate_Compilation_Unit
             |  Asis.Exceptions.ASIS_Inappropriate_Element
             |  Asis.Exceptions.ASIS_Inappropriate_Line
             |  Asis.Exceptions.ASIS_Inappropriate_Line_Number
             |  Asis.Exceptions.ASIS_Failed
        =>
         New_Line (File => Standard_Error);

         if Asis.Implementation.Status = Asis.Errors.Use_Error and then
            Reuse_Tree and then Tree_Exists
         then
            Put      (Standard_Error, "gnatstub: the tree you try to reuse ");
            Put_Line (Standard_Error, "may be obsolete");
            Put      (Standard_Error, "gnatstub: either recreate the tree ");
            Put_Line (Standard_Error, "or do not use -r option");
         else
            Put      (Standard_Error, "Unexpected bug in ");
            Put_Gnatstub_Version;
            New_Line (Standard_Error);
            Put      (Standard_Error, Exception_Name (Ex));
            Put_Line (Standard_Error, " raised");
            Put      (Standard_Error, "gnatstub: ASIS Diagnosis is "
                     & To_String (Asis.Implementation.Diagnosis));
            New_Line (Standard_Error);
            Put      (Standard_Error, "gnatstub: Status Value   is ");
            Put_Line (Standard_Error, Asis.Errors.Error_Kinds'Image
                        (Asis.Implementation.Status));
            New_Line (Standard_Error);
            Put_Line (Standard_Error, "Please report to report@gnat.com");
         end if;

         Emergency_Clean_Up;
         raise Fatal_Error;

      when others =>
         Emergency_Clean_Up;
         raise;
   end Create_Sample;

   ---------------------
   -- Prepare_Context --
   ---------------------

   procedure Prepare_Context is separate;
   --  We need different bodies for GNSA and non-GNSA versions

   ------------------------
   -- Emergency_Clean_Up --
   ------------------------

   procedure Emergency_Clean_Up is
   begin
      if Is_Open (My_Context) then
         Close (My_Context);
      end if;

      Dissociate (My_Context);
      Finalize;

      if Is_Open (Body_File) then
         --  No need to keep a broken body in case of an emergency clean up
         Delete (Body_File);
      end if;

      if Is_Open (Spec_File) then
         --  No need to keep a broken body in case of an emergency clean up
         Close (Spec_File);
      end if;

   end Emergency_Clean_Up;

   -----------------------------
   -- Generate_Body_Structure --
   -----------------------------

   procedure Generate_Body_Structure is

      procedure Print_Node (Node : Link);
      --  outputs a Node into Body_File

      procedure Print_Node_List (List : Link);
      --  outputs a list of nodes into Body_File. These two procedures -
      --  Print_Node and Print_Node_List call each other recursively

      procedure Print_Node (Node : Link) is
         Arg_Kind : constant Flat_Element_Kinds :=
           Flat_Element_Kind (Node.Spec);
      begin

         if Node /= Body_Structure'Access and then Bodyless_Package (Node) then
            return;
         end if;

         if Level /= 0
           and then
            Arg_Kind not in An_Incomplete_Type_Declaration ..
                            A_Tagged_Incomplete_Type_Declaration
         then
            Generate_Unit_Header (Node);
         end if;

         case Arg_Kind is

            when A_Package_Declaration |
                 A_Generic_Package_Declaration =>
               Generate_Package_Body (Node);

            when A_Function_Declaration |
                 A_Generic_Function_Declaration =>
               Generate_Function_Body (Node);

            when A_Procedure_Declaration |
                 A_Generic_Procedure_Declaration =>
               Generate_Procedure_Body (Node);

            when An_Entry_Declaration =>
               Generate_Entry_Body (Node);

            when A_Single_Protected_Declaration |
                 A_Protected_Type_Declaration =>
               Generate_Protected_Body (Node);

            when A_Single_Task_Declaration |
                 A_Task_Type_Declaration =>
               Generate_Task_Body (Node);

            when An_Incomplete_Type_Declaration       |
                 A_Tagged_Incomplete_Type_Declaration =>
               Generate_Full_Type_Declaration (Node);

            when others =>
               Put      (Standard_Error, "gnatstub: unexpected element ");
               Put_Line (Standard_Error, "in the body structure");
               raise Fatal_Error;
         end case;

         if Node.Down /= null then
            Print_Node_List (Node.Down);
         end if;

      end Print_Node;

      procedure Print_Node_List (List : Link) is
         Next_Node  : Link;
         List_Start : Link := List;
      begin
         Level := Level + 1;

         --  here we have to go to the beginning of the list:

         while List_Start.Prev /= null loop
            List_Start := List_Start.Prev;
         end loop;

         Next_Node := List_Start;

         loop
            Print_Node (Next_Node);

            if Next_Node.Next /= null then
               Next_Node := Next_Node.Next;
            else
               exit;
            end if;

         end loop;

         --  finalizing the enclosing construct:
         Level := Level - 1;
         Next_Node := Next_Node.Up;

         Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level));

         Put_Line (Body_File, "end " & Next_Node.Spec_Name.all & ";");

         if List.Up /= Body_Structure'Access then
            New_Line (Body_File);
         end if;

      end Print_Node_List;

   begin

      Print_Node (Body_Structure'Access);

   end Generate_Body_Structure;

   ------------------------
   -- Generate_CU_Header --
   ------------------------

   procedure Generate_CU_Header (Success   : out Boolean) is

      --  This local declarations are used to generate a sample comment
      --  header
      Unit_Name_Len          : Positive := Body_Structure.Spec_Name'Length;
      Left_Unit_Name_Spaces  : Positive;
      Right_Unit_Name_Spaces : Positive;
      Left_Body_Spaces       : Positive;
      Right_Body_Spaces      : Positive;
      Name_With_Spaces       : Boolean := True;
      Body_String            : constant String := "B o d y";
      Body_String_Len        : constant Positive := Body_String'Length;

      --  This local declarations are used to copy a comment header from the
      --  argument spec
      Header_File            : File_Type;
      String_Buf             : String (1 .. Hostparm.Max_Line_Length);
      Header_Line_Len        : Natural;
      Idx                    : Natural;
      Line_Count             : Natural := 0;
      Spec_String_Start      : Natural;

      procedure Strip_Trailing_Spaces;
      --  Strips trailing spaces from the string stored in String_Buf
      --  (assuming that Header_Line_Len points to the last character of this
      --  string) and resets Header_Line_Len accordingly.

      procedure Strip_Trailing_Spaces is
      begin

         for J in reverse 1 .. Header_Line_Len loop

            if not Is_White_Space (String_Buf (J)) then
               Header_Line_Len := J;
               exit;
            end if;

         end loop;

      end Strip_Trailing_Spaces;

   begin
      Success := False;

      case Header is

         when No_Header =>
            null;

         when Stand_Header =>
            --  first, checking if we can fit the maximum line length:

            if Unit_Name_Len + 6 > Max_Body_Line_Length then

               Put (Standard_Error, "gnatstub: argument unit name is too ");
               Put_Line (Standard_Error, "long to generate a comment header");
               Put      (Standard_Error, "gnatstub: try to increase ");
               Put_Line (Standard_Error, "the maximum body line length");
               raise Fatal_Error;

            elsif (2 * Unit_Name_Len -1) + 6 > Max_Body_Line_Length then
               Name_With_Spaces := False;
            else
               Unit_Name_Len := 2 * Unit_Name_Len -1;
            end if;

            Left_Unit_Name_Spaces  :=
              (Max_Body_Line_Length - 4 - Unit_Name_Len) / 2;
            Right_Unit_Name_Spaces :=
              Max_Body_Line_Length - Unit_Name_Len -
                4 - Left_Unit_Name_Spaces;

            Left_Body_Spaces  :=
              (Max_Body_Line_Length - 4 - Body_String_Len) / 2;
            Right_Body_Spaces :=
               Max_Body_Line_Length - Body_String_Len - 4 - Left_Body_Spaces;

            Put_Line (Body_File, Max_Body_Line_Length * '-');
            Put_Line
              (Body_File, "--" & (Max_Body_Line_Length - 4) * ' ' & "--");

            Put (Body_File, "--" & Left_Unit_Name_Spaces * ' ');

            if Name_With_Spaces then
               Put (Body_File, To_Upper (Body_Structure.Spec_Name
                               (Body_Structure.Spec_Name'First)));

               for I in Body_Structure.Spec_Name'First + 1 ..
                        Body_Structure.Spec_Name'Last
               loop
                  Put
                    (Body_File, ' ' & To_Upper (Body_Structure.Spec_Name (I)));
               end loop;

            else
               Put (Body_File, To_Upper (Body_Structure.Spec_Name.all));
            end if;

            Put_Line (Body_File, Right_Unit_Name_Spaces * ' ' & "--");

            Put_Line
              (Body_File, "--" & (Max_Body_Line_Length - 4) * ' ' & "--");

            Put_Line (Body_File,
                      "--" & Left_Body_Spaces * ' ' &
                      Body_String & Right_Body_Spaces * ' ' &  "--");

            Put_Line
              (Body_File, "--" & (Max_Body_Line_Length - 4) * ' ' & "--");
            Put_Line
              (Body_File, Max_Body_Line_Length * '-');
            New_Line (Body_File);

         when From_Spec =>

            Open (Header_File, In_File, File_Name.all, "");

            while not End_Of_File (Header_File) loop
               Get_Line (Header_File, String_Buf, Header_Line_Len);
               Strip_Trailing_Spaces;
               Line_Count := Line_Count + 1;

               exit when String_Buf (1 .. 2) /= "--";

               if Header_Line_Len  > Max_Body_Line_Length then
                  Put      (Standard_Error, "gnatstub: line" & Line_Count'Img);
                  Put      (Standard_Error, " in spec's comment header");
                  Put_Line (Standard_Error, " is too long");
                  Put      (Standard_Error, "try to increase ");
                  Put_Line (Standard_Error, "the maximum body line length");

                  Close (Header_File);

                  raise Fatal_Error;
               end if;

               Spec_String_Start :=
                  Index (Source => String_Buf (1 .. Header_Line_Len),
                         Pattern => "S p e c");

               if Spec_String_Start /= 0 then
                  Overwrite (Source   => String_Buf (1 .. Header_Line_Len),
                             Position => Spec_String_Start,
                             New_Item => "B o d y");
               end if;

               Put_Line (Body_File, String_Buf (1 .. Header_Line_Len));

            end loop;

            Close (Header_File);

         when From_File =>

            Open (Header_File, In_File, Header_File_Name.all, "");

            while not End_Of_File (Header_File) loop
               Get_Line (Header_File, String_Buf, Header_Line_Len);
               Strip_Trailing_Spaces;
               Line_Count := Line_Count + 1;
               Idx        := ASIS_Index_Non_Blank (String_Buf);

               if Idx /= 0
                 and then
                  (Header_Line_Len - Idx = 0
                  or else
                   String_Buf (Idx .. Idx + 1) /= "--")
               then
                  Put      (Standard_Error, "gnatstub: line" & Line_Count'Img);
                  Put      (Standard_Error, " in comment header file");
                  Put_Line (Standard_Error, " is not a comment line");

                  Close (Header_File);

                  raise Fatal_Error;
               elsif Header_Line_Len > Max_Body_Line_Length then
                  Put      (Standard_Error, "gnatstub: line" & Line_Count'Img);
                  Put      (Standard_Error, " in comment header file");
                  Put_Line (Standard_Error, " is too long");
                  Put      (Standard_Error, "try to increase ");
                  Put_Line (Standard_Error, "the maximum body line length");

                  Close (Header_File);

                  raise Fatal_Error;
               end if;

               Put_Line (Body_File, String_Buf (1 .. Header_Line_Len));

            end loop;

            Close (Header_File);

      end case;

      Success := True;

   exception
      when others =>
         Emergency_Clean_Up;
         raise;
   end Generate_CU_Header;

   -------------------------
   -- Generate_Entry_Body --
   -------------------------

   procedure Generate_Entry_Body (Node : Link) is
      Change_Line : Boolean;
   begin
      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put (Body_File, "entry " & Node.Spec_Name.all);

      Generate_Profile (Node, Change_Line);

      if Change_Line then
         New_Line (Body_File);
         Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));
      else
         Put (Body_File, " ");
      end if;

      Put (Body_File, "when True");

      --  now we have to decide how to output "is"
      if Change_Line or else
         Natural (Col (Body_File)) + 3 > Max_Body_Line_Length
      then
         New_Line (Body_File);
         Set_Col  (Body_File, Positive_Count (1 + (Level) * Indent_Level));
      else
         Put (Body_File, ' ');
      end if;

      Put_Line (Body_File, "is");

      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put_Line (Body_File, "begin");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));
      Put_Line (Body_File, "--  Generated stub: replace with real body!");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));
      Put_Line (Body_File,
                "pragma Compile_Time_Warning (True, """ &
                Node.Spec_Name.all & " unimplemented"");");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));

      if No_Exception_In_Stubs then
         Put_Line (Body_File, "null;");
      else
         Put (Body_File, "raise Program_Error");

         if ASIS_UL.Options.ASIS_2005_Mode_Explicitely_Set then
            Put (Body_File,
                 " with ""Unimplemented entry " &  Node.Spec_Name.all & '"');
         end if;

         Put_Line (Body_File, ";");
      end if;

      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put_Line (Body_File, "end " & Node.Spec_Name.all & ";");

      New_Line (Body_File);
   end Generate_Entry_Body;

   ------------------------------------
   -- Generate_Full_Type_Declaration --
   ------------------------------------

   procedure Generate_Full_Type_Declaration (Node : Link) is
      Discr_Part : constant Asis.Element := Discriminant_Part (Node.Spec);
      Is_Tagged  : constant Boolean      := Flat_Element_Kind (Node.Spec) =
        A_Tagged_Incomplete_Type_Declaration;

   begin
      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put (Body_File, "type " & Node.Spec_Name.all & " ");

      if Flat_Element_Kind (Discr_Part) = A_Known_Discriminant_Part then
         --  we do not split components of a discriminant part to fit
         --  Max_Body_Line_Length constraint (if needed) - it does not make any
         --  sense, because a user will for sure change this sample completion
         --  for an incomplete type declaration
         Put (Body_File,
              ASIS_Trim (To_String (Element_Image (Discr_Part))) & " ");
      end if;

      Put (Body_File, "is ");

      if Is_Tagged then
         Put (Body_File, "tagged ");
      end if;

      Put_Line (Body_File, "null record;");

      New_Line (Body_File);
   end Generate_Full_Type_Declaration;

   ----------------------------
   -- Generate_Function_Body --
   ----------------------------

   procedure Generate_Function_Body (Node : Link) is
      No_Raise_Stataement : Boolean := False;

      Parameters : constant Asis.Element_List := Parameter_Profile (Node.Spec);

      Change_Line  : Boolean;
      First_Formal : Boolean := True;

      Next_Pos     : Natural;

      procedure Output_Fake_Parameters;
      --  Prints out the fake parameters of the fake recursive call of the
      --  function to itself

      procedure Output_Fake_Parameters is
         Start_Pos : constant Positive_Count :=
           Positive_Count (1 + (Level + 2) * Indent_Level);

         Next_Len : Natural;

      begin

         if Next_Pos >= Max_Body_Line_Length then
            Set_Col  (Body_File, Start_Pos - 1);
            Next_Pos := Natural (Start_Pos - 1);
         end if;

         Put (Body_File, " (");
         Next_Pos := Next_Pos + 1;

         for J in Parameters'Range loop

            declare
               Formal_Names : constant Asis.Element_List :=
                 Names (Parameters (J));
            begin

               for K in Formal_Names'Range loop
                  Next_Len := Defining_Name_Image (Formal_Names (K))'Length;

                  if First_Formal then
                     First_Formal := False;

                     Put
                       (Body_File,
                        To_String (Defining_Name_Image (Formal_Names (K))));

                     Next_Pos := Next_Pos + Next_Len;
                  else
                     Put (Body_File, ",");
                     Next_Pos := Next_Pos + 1;

                     if Next_Pos + 2 + Next_Len > Max_Body_Line_Length then
                        Set_Col (Body_File, Start_Pos);
                        Next_Pos := Natural (Start_Pos);
                     else
                        Put (Body_File, " ");
                        Next_Pos := Next_Pos + 1;
                     end if;

                     Put
                       (Body_File,
                        To_String (Defining_Name_Image (Formal_Names (K))));

                     Next_Pos := Next_Pos + Next_Len;

                  end if;

               end loop;

            end;

         end loop;

         Put (Body_File, ");");

      end Output_Fake_Parameters;

   begin
      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));

      if Is_Overriding_Declaration (Node.Spec) then
         Put (Body_File, "overriding ");
      elsif Is_Not_Overriding_Declaration (Node.Spec) then
         Put (Body_File, "not overriding ");
      end if;

      Put (Body_File, "function " & Node.Spec_Name.all);
      Generate_Profile (Node, Change_Line);

      if Change_Line then
         Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
         Put_Line (Body_File, "is");
      else
         Put_Line (Body_File, " is");
      end if;

      if No_Exception_In_Stubs
        and then
         Allows_Var_Declaration (Result_Profile (Node.Spec))
      then
         No_Raise_Stataement := True;
         Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));
         Put (Body_File, "Result : ");
         Put (Body_File,
              ASIS_Trim (To_String
                (Element_Image (Result_Profile (Node.Spec)))));
         Put_Line (Body_File, ";");
      end if;

      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put_Line (Body_File, "begin");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));
      Put_Line (Body_File, "--  Generated stub: replace with real body!");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));
      Put_Line (Body_File,
                "pragma Compile_Time_Warning (True, """ &
                Image_For_String (Node.Spec_Name.all) & " unimplemented"");");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));

      if No_Raise_Stataement then
         Put_Line (Body_File, "return Result;");
      else
         Put (Body_File, "raise Program_Error");

         if ASIS_UL.Options.ASIS_2005_Mode_Explicitely_Set then
            Put (Body_File,
                 " with ""Unimplemented function " &
                 Image_For_String (Node.Spec_Name.all) & '"');
         end if;

         Put_Line (Body_File, ";");

         Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));
         --  generating a dummy recursive call to itself:
         Put (Body_File, "return " & Node.Spec_Name.all);

         Next_Pos :=
           1 + (Level + 1) * Indent_Level + 6 + 1 + Node.Spec_Name'Length;

         if Parameters'Length = 0 then
            Put_Line (Body_File, ";");
         else
            Output_Fake_Parameters;
         end if;

      end if;

      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put_Line (Body_File, "end " & Node.Spec_Name.all & ";");

      New_Line (Body_File);
   end Generate_Function_Body;

   ---------------------------
   -- Generate_Package_Body --
   ---------------------------

   procedure Generate_Package_Body (Node : Link) is
   begin
      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put_Line (Body_File, "package body " & Node.Spec_Name.all & " is");
      New_Line (Body_File);

      if Node = Body_Structure'Access and then Node.Down = null then
         --  this is a special case: an argument unit is a library [generic]
         --  package which requires a body but which does not contain any
         --  local declaration which itself requires a completion:
         Put_Line (Body_File, "end " & Node.Spec_Name.all & ";");
      end if;
   end Generate_Package_Body;

   -----------------------------
   -- Generate_Procedure_Body --
   -----------------------------

   procedure Generate_Procedure_Body (Node : Link) is
      Change_Line : Boolean;

   begin
      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));

      if Is_Overriding_Declaration (Node.Spec) then
         Put (Body_File, "overriding ");
      elsif Is_Not_Overriding_Declaration (Node.Spec) then
         Put (Body_File, "not overriding ");
      end if;

      Put (Body_File, "procedure " & Node.Spec_Name.all);
      Generate_Profile (Node, Change_Line);

      if Change_Line then
         Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
         Put_Line (Body_File, "is");
      else
         Put_Line (Body_File, " is");
      end if;

      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put_Line (Body_File, "begin");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));
      Put_Line (Body_File, "--  Generated stub: replace with real body!");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));
      Put_Line (Body_File,
                "pragma Compile_Time_Warning (True, """ &
                Node.Spec_Name.all & " unimplemented"");");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));

      if No_Exception_In_Stubs then
         Put_Line (Body_File, "null;");
      else
         Put (Body_File, "raise Program_Error");

         if ASIS_UL.Options.ASIS_2005_Mode_Explicitely_Set then
            Put (Body_File,
                 " with ""Unimplemented procedure " &
                 Node.Spec_Name.all & '"');
         end if;

         Put_Line (Body_File, ";");
      end if;

      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put_Line (Body_File, "end " & Node.Spec_Name.all & ";");

      New_Line (Body_File);
   end Generate_Procedure_Body;

   ----------------------
   -- Generate_Profile --
   ----------------------

   procedure Generate_Profile (Node : Link; Change_Line : out Boolean) is
      Arg_Kind  : constant Flat_Element_Kinds := Flat_Element_Kind (Node.Spec);
      Parameters : constant Asis.Element_List := Parameter_Profile (Node.Spec);
      Spec_Span : Span;
      Family_Def : Asis.Element;

      Construct_Len : Positive;

   begin
      Change_Line := False;

      --  first, generating an entry_index_specification for an entry_body,
      --  if needed:

      if Arg_Kind = An_Entry_Declaration then
         Family_Def := Entry_Family_Definition (Node.Spec);

         if not Is_Nil (Family_Def) then
            Spec_Span := Element_Span (Family_Def);

            --  checking how entry_index_specification should be printed
            --  "+ 12" below means " (for I in )"
            if (Spec_Span.First_Line /= Spec_Span.Last_Line) or else
                (Character_Position (Col (Body_File)) + 12 +
                 Spec_Span.Last_Column - Spec_Span.First_Column + 1) >
               Max_Body_Line_Length
            then
               Change_Line := True;
            end if;

            if Change_Line then
               New_Line (Body_File);

               if Indent_Level > 0 then
                  Set_Col (
                     Body_File,
                     Positive_Count (1 + (Level + 1) * Indent_Level) - 2);
               end if;

            end if;

            Put (Body_File, " (for I in ");
            Put (Body_File,
                 ASIS_Trim (To_String (Element_Image (Family_Def))));
            Put (Body_File, ")");
         end if;
      end if;

      --  Now we have to decide, how to print parameter [and result] profile
      if Change_Line = False then

         if Arg_Kind = A_Generic_Procedure_Declaration or else
            Arg_Kind = A_Generic_Function_Declaration
         then
            --  Here we cannot use Span-based approach, so we use the
            --  rough parameter-number-based estimation:
            if Parameters'Length >= 2 then
               Change_Line   := True;
            end if;

         else

            Spec_Span := Element_Span (Node.Spec);

            if Spec_Span.First_Line /= Spec_Span.Last_Line then
               --  First, rough check: if an argument spec occupies more then
               --  one line, we print parameters specs on separate lines:
               Change_Line   := True;
            else
               --  We check if a construct plus additions needed for the body
               --  plus indentation level in the body fits maximum line length
               --  defined for the body. We assume that the argument spec is
               --  reasonably formatted

               Construct_Len := Spec_Span.Last_Column - Spec_Span.First_Column
                                + 1;

               if Arg_Kind = An_Entry_Declaration and then
                   not Is_Nil (Family_Def)
               then
                  Construct_Len := Construct_Len + 9;
                  --  "+ 9" stands for "for I in "
               else
                  Construct_Len := Construct_Len + 3;
                  --  "+ 3" stands for " is"
               end if;

               if Level * Indent_Level + Construct_Len >
                  Max_Body_Line_Length
               then
                  Change_Line := True;
               end if;
            end if;
         end if;
      end if;

      if not Is_Nil (Parameters) then

         if Change_Line then
            New_Line (Body_File);

            if Indent_Level > 0 then
               Set_Col  (Body_File,
                         Positive_Count (1 + (Level + 1) * Indent_Level - 1));
            end if;

            Put (Body_File, "(");
         else
            Put (Body_File, " (");
         end if;

         for I in Parameters'Range loop
            Put (Body_File,
                 ASIS_Trim (To_String (Element_Image (Parameters (I)))));

            if I /= Parameters'Last then

               if Change_Line then
                  Put_Line (Body_File, ";");
                  Set_Col  (Body_File,
                            Positive_Count (1 + (Level + 1) * Indent_Level));
               else
                  Put (Body_File, "; ");
               end if;
            end if;
         end loop;

         Put (Body_File, ")");

      end if;

      if Arg_Kind = A_Function_Declaration or else
         Arg_Kind = A_Generic_Function_Declaration
      then
         --  we have to output " return <type_mark>:
         if Change_Line then
            New_Line (Body_File);
            Set_Col  (Body_File,
                      Positive_Count (1 + (Level + 1) * Indent_Level));
            Put (Body_File, "return ");
         else
            Put (Body_File, " return ");
         end if;

         if Definition_Kind (Result_Profile (Node.Spec)) /=
            An_Access_Definition
          and then
            Is_Not_Null_Return (Node.Spec)
         then
            Put (Body_File, "not null ");
         end if;

         Put (Body_File,
              ASIS_Trim (To_String
                (Element_Image (Result_Profile (Node.Spec)))));

      end if;

      if Col (Body_File) + 3 > Ada.Text_IO.Count (Max_Body_Line_Length) then
         Change_Line   := True;
      end if;
   end Generate_Profile;

   -----------------------------
   -- Generate_Protected_Body --
   -----------------------------

   procedure Generate_Protected_Body (Node : Link) is
   begin
      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put_Line (Body_File, "protected body " & Node.Spec_Name.all & " is");
      New_Line (Body_File);

      if Node.Down = null then
         --  protected definition with no protected operation is somewhat
         --  strange, but legal case
         Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
         Put_Line (Body_File, "end " & Node.Spec_Name.all & ";");
         New_Line (Body_File);
      end if;
   end Generate_Protected_Body;

   ------------------------
   -- Generate_Task_Body --
   ------------------------

   procedure Generate_Task_Body (Node : Link) is
   begin
      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put_Line (Body_File, "task body " & Node.Spec_Name.all & " is");

      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put_Line (Body_File, "begin");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));
      Put_Line (Body_File, "--  Generated stub: replace with real body!");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));
      Put_Line (Body_File,
                "pragma Compile_Time_Warning (True, """ &
                Node.Spec_Name.all & " unimplemented"");");

      Set_Col  (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level));

      if No_Exception_In_Stubs then
         Put_Line (Body_File, "null;");
      else
         Put (Body_File, "raise Program_Error");

         if ASIS_UL.Options.ASIS_2005_Mode_Explicitely_Set then
            Put (Body_File,
                 " with ""Unimplemented task " &  Node.Spec_Name.all & '"');
         end if;

         Put_Line (Body_File, ";");
      end if;

      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      Put_Line (Body_File, "end " & Node.Spec_Name.all & ";");
      New_Line (Body_File);
   end Generate_Task_Body;

   --------------------------
   -- Generate_Unit_Header --
   --------------------------

   procedure Generate_Unit_Header (Node : Link) is
      Header_Length : constant Natural := Node.Spec_Name'Length + 6;
   begin
      if not No_Local_Comment_Headers then
         Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
         Put_Line (Body_File, Header_Length * '-');

         Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
         Put      (Body_File, "-- ");
         Put      (Body_File, Node.Spec_Name.all);
         Put_Line (Body_File, " --");

         Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
         Put_Line (Body_File, Header_Length * '-');
         New_Line (Body_File);
      end if;
   end Generate_Unit_Header;

   -------------------
   -- Get_Tree_Name --
   -------------------

   function Get_Tree_Name return String is
      Dot_Index : Natural := Short_File_Name'Last;
   begin

      for J in reverse Short_File_Name'Range loop
         if Short_File_Name (J) = '.' then
            Dot_Index := J - 1;
            exit;
         end if;
      end loop;

      return Short_File_Name (Short_File_Name'First .. Dot_Index) & ".adt";
   end Get_Tree_Name;

   -----------
   -- Go_Up --
   -----------

   procedure Go_Up
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Body_State)
   is
      pragma Unreferenced (Control);

      Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Element);
   begin
      if not (Arg_Kind = A_Package_Declaration or else
              Arg_Kind = A_Generic_Package_Declaration or else
              Arg_Kind = A_Single_Protected_Declaration or else
              Arg_Kind = A_Protected_Type_Declaration)
      then
         return;
      end if;

      if State.New_List_Needed then
         --  no local body is needed for a given construct
         State.New_List_Needed := False;
      else
         --  we have to reset the current list:

         if State.Current_List /= null then
            State.Current_List := State.Current_List.Up;
            while State.Current_List.Prev /= null loop
               State.Current_List := State.Current_List.Prev;
            end loop;
         end if;
      end if;
   end Go_Up;

   -----------------------
   --  Image_For_String --
   -----------------------

   function Image_For_String (S : String) return String is
   begin
      if S (S'First) = '"' and then S (S'Last) = '"' then
         return '"' & S & '"';
      else
         return S;
      end if;
   end Image_For_String;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      Scan_Gnatstub_Arguments;
      Check_Parameters;
      Prepare_Context;

      Initialized := True;

   exception
      when others =>
         Initialized := False;
         raise;
   end Initialize;

   ----------
   -- Name --
   ----------

   function Name (El : Asis.Element) return String is
      Def_Name        : constant Asis.Element := Names (El) (1);
      Def_Name_String : constant String :=
        To_String (Defining_Name_Image (Def_Name));
   begin
      return Def_Name_String;
   end Name;

   --------------------------
   -- Put_Gnatstub_Version --
   --------------------------

   procedure Put_Gnatstub_Version is
   begin
      Put (Standard_Error, "GNATSTUB (built with ");
      Put
        (Standard_Error,
         To_String (Asis.Implementation.ASIS_Implementor_Version));
      Put (Standard_Error, ")");
   end Put_Gnatstub_Version;

   -------------------
   -- Requires_Body --
   -------------------

   function Requires_Body (El : Element) return Boolean is
      Arg_Kind     : constant Flat_Element_Kinds := Flat_Element_Kind (El);
      Encl_El      : Asis.Element;
      Encl_El_Kind : Flat_Element_Kinds;
      Result       : Boolean := False;

   begin

      case Arg_Kind is
         when An_Incomplete_Type_Declaration       |
              A_Tagged_Incomplete_Type_Declaration =>
            Result := Is_Nil (Corresponding_Type_Declaration (El));
         when A_Task_Type_Declaration         |
              A_Protected_Type_Declaration    |
              A_Single_Task_Declaration       |
              A_Single_Protected_Declaration  |
              A_Package_Declaration           |
              A_Generic_Procedure_Declaration |
              A_Generic_Function_Declaration  |
              A_Generic_Package_Declaration    =>

            --  there is no harm to generate a local body sample for a local
            --  package or generic package
            Result := True;

         when A_Procedure_Declaration |
              A_Function_Declaration    =>

            --  there are two cases when a subprogram does not require
            --  completion: when it is already completed by renaming-as-body
            --  in a package spec or when it is abstract

            if Trait_Kind (El) /= An_Abstract_Trait then
               --  Result := Is_Nil (Corresponding_Body (El));  ???
               --  ??? the statement below implements the temporary solution
               --  ??? for subprograms completed by pragmas Import.
               --  ??? it should be revised when Asis.Extensions.Is_Completed
               --  ??? gets in a proper shape.

               Result := not (not Is_Nil (Corresponding_Body (El))
                          or else
                              Asis.Extensions.Is_Completed (El));
            end if;

         when An_Entry_Declaration =>
            Encl_El      := Enclosing_Element (El);
            Encl_El_Kind := Flat_Element_Kind (Encl_El);
            Result := Encl_El_Kind = A_Protected_Definition;
         when others =>
            null;
      end case;

      return Result;

   end Requires_Body;

   -----------------------------
   -- Scan_Gnatstub_Arguments --
   -----------------------------

   procedure Scan_Gnatstub_Arguments is
      Nat : Natural;

   begin

      --  For some parameters, we have two options to set the same thing.
      --  When gnatstub was initially developed, it introduced its
      --  own options for everything, including controlling the layout of
      --  the generated code. Then it was realized that it would make sense
      --  to use for setting the layout of the gnatstub-generated code the
      --  same options as used to set the GNAT style checking mode (see
      --  C307-004). And the old gnatstub versions are kept for back
      --  compatibility

      Initialize_Option_Scan
        (Stop_At_First_Non_Switch => False,
         Section_Delimiters       => "cargs");
      loop

         case
            GNAT.Command_Line.Getopt
              ("f hs hg k o= q r t v "  & --  general gnatstub
               "-header-file= "         & --  options
               "-no-exception "         & --  no raise stmt in procedure stubs
               "-no-local-header "      & --  no local comment headers
               "i! l! "                 & --  old layout control options
               "gnatyo gnaty! gnatyM! " & --  GNAT-style layout control
               "I! gnatec! "            &
               "gnat05")                   --  process Ada 2005 construct
         is
            when ASCII.NUL =>
               exit;

            when 'f' =>
               Overwrite_Body := True;

            when 'g' =>

               if Full_Switch = "gnatec" then
                  Store_GNAT_Option_With_Path (Full_Switch, Parameter);

               elsif Full_Switch = "gnatyo" then
                  Alphabetical_Ordering := True;

               elsif Full_Switch = "gnatyM" then
                  Nat := Get_Nat_Switch_Parameter (Parameter);

                  if Nat = 0 then
                     Put_Line
                       (Standard_Error,
                        "gnatstub: body line length cannot be 0");
                     raise Parameter_Error;
                  else
                     Max_Body_Line_Length := Nat;
                  end if;

               elsif Full_Switch = "gnaty" then
                  Nat := Get_Nat_Switch_Parameter (Parameter);

                  if Nat not in 1 .. 9 then
                     Put      (Standard_Error, "gnatstub: indentation level ");
                     Put_Line (Standard_Error, "should be from 1 .. 9");
                     raise Parameter_Error;
                  else
                     Indent_Level := Nat;
                  end if;

               elsif Full_Switch = "gnat05" then
                  ASIS_UL.Options.ASIS_2005_Mode                 := True;
                  ASIS_UL.Options.ASIS_2005_Mode_Explicitely_Set := True;
               end if;

            when 'h' =>

               if Full_Switch = "hg" then
                  Header := Stand_Header;
               elsif Full_Switch = "hs"then
                  Header := From_Spec;
               elsif Full_Switch = "header_file" then
                  Header_File_Name := new String'(Parameter);
                  Header           := From_File;
--               elsif Full_Switch = "-header_file" then
--                  Header_File_Name := new String'(Parameter);
--                  Header           := From_File;
               end if;

            when 'i' =>
               --  Old-style option for setting the indentation level,
               --  the GNAT-style option is -gnaty

               Nat := Get_Nat_Switch_Parameter (Parameter);

               if Nat not in 1 .. 9 then
                  Put      (Standard_Error, "gnatstub: indentation level ");
                  Put_Line (Standard_Error, "should be from 1 .. 9");
                  raise Parameter_Error;
               else
                  Indent_Level := Nat;
               end if;

            when 'I' =>
                  Store_I_Option (Parameter);

            when 'k' =>
               Delete_Tree := False;

            when 'l' =>
               --  Old-style option for setting the indentation level,
               --  the GNAT-style option is -gnaty

               Nat := Get_Nat_Switch_Parameter (Parameter);

               if Nat = 0 then
                  Put_Line
                    (Standard_Error,
                     "gnatstub: body line length cannot be 0");
                  raise Parameter_Error;
               else
                  Max_Body_Line_Length := Nat;
               end if;

            when 'o' =>
               Body_Name := new String'(Parameter);

            when 'q' =>
               Quiet_Mode := True;

            when 'r' =>
               Reuse_Tree := True;

            when 't' =>
               Overwrite_Tree := True;

            when 'v' =>
               Verbose_Mode := True;
               Put_Gnatstub_Version;
               New_Line  (Standard_Error);
               Put
                 (Standard_Error,
                  "Copyright 1997-" &
                  Gnatvsn.Current_Year &
                  ", Free Software Foundation, Inc.");
               New_Line (Standard_Error);

            when '-' =>

               if Full_Switch = "-header-file" then
                  Header_File_Name := new String'(Parameter);
                  Header           := From_File;
               elsif Full_Switch = "-no-exception" then
                  No_Exception_In_Stubs := True;
               elsif Full_Switch = "-no-local-header" then
                  No_Local_Comment_Headers := True;
               end if;

            when others =>
               Brief_Help;
               raise Parameter_Error;
         end case;

      end loop;

      File_Name       := new String'(Get_Argument);
      Destination_Dir := new String'(Get_Argument);

      --  If there is no argument file name or no destination directory,
      --  we will get empty strings here

      if File_Name.all = "" then
         Put_Line (Standard_Error, "gnatstub: file name is missed");
         Brief_Help;
         raise Parameter_Error;
      end if;

      if Get_Argument /= "" then
         Put (Standard_Error, "gnatstub: only one file name and at most one ");
         Put (Standard_Error, "destination directory are allowed");
         New_Line (Standard_Error);
         Brief_Help;
         raise Parameter_Error;
      end if;

      Process_cargs_Section;

   exception
      when GNAT.Command_Line.Invalid_Switch =>
         Ada.Text_IO.Put_Line (Standard_Error,
                              "gnatstub: invalid switch : "
                             & GNAT.Command_Line.Full_Switch);
         Brief_Help;

         raise Parameter_Error;

      when GNAT.Command_Line.Invalid_Parameter =>
         Ada.Text_IO.Put_Line (Standard_Error,
                              "gnatstub: missing parameter for: "
                               & GNAT.Command_Line.Full_Switch);
         Brief_Help;

         raise Parameter_Error;
   end Scan_Gnatstub_Arguments;

end Gnatstub.Sampler;
