------------------------------------------------------------------------------
--                                                                          --
--                           GNATSTUB COMPONENTS                            --
--                                                                          --
--                      G N A T S T U B . S A M P L E R                     --
--                                                                          --
--                               B o d y                                    --
--                                                                          --
--                            $Revision: 1.23 $
--                                                                          --
--           Copyright (c) 1997-2002, 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, 59 Temple Place Suite 330,   --
-- Boston, MA 02111-1307, 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  Ada  Core  Technologies  Inc          --
-- (http://www.gnat.com).                                                   --
------------------------------------------------------------------------------

with Ada.Text_IO;                use Ada.Text_IO;
with Ada.Exceptions;             use Ada.Exceptions;
with Ada.Characters.Handling;    use Ada.Characters.Handling;
with Ada.Command_Line;           use Ada.Command_Line;
with Ada.Strings;                use Ada.Strings;
with Ada.Strings.Fixed;          use Ada.Strings.Fixed;

with Ada.Unchecked_Deallocation;

with GNAT.OS_Lib;                use GNAT.OS_Lib;

with Gnatstub.Options;           use Gnatstub.Options;

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

with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds;

with A4G.GNAT_Int;               use A4G.GNAT_Int;

package body Gnatstub.Sampler is

   Parameter_Error : exception;

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

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

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

   procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr);

   procedure Make_Unit_Name (CU_Name : in out String);
   --  converts the file name (without extension) into a unit name
   --  by replacing '-' by '.'

   procedure Scan_Gnatstub_Arg (Argv : String);
   --  Scan gnatstub arguments. Argv is a single argument to be processed.
   --  If an argument is illegal, generates the diagnostic message and
   --  raises Parameter_Error

   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 Create_Tree;
   --  Creates a tree file or checks if the tree file already exists,
   --  depending on options

   procedure Unknown_Option (Argv : String);
   --  Output the giagnosis of the form "gnatstub : unknown option <Argv>"
   --  and raises Parameter_Error

   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;
   end record;
   --  an element of a dynamic structure representing a "skeleton" of the body\
   --  to be generated

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

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

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

   function Bodyless_Package (Node : Link) return Boolean is
      Result : Boolean := False;
      Arg_Kind : 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
   begin

      Put_Line ("Usage: gnatstub [opts] filename [directory]");
      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_Line ("  -f     replace an existing body file (if any) with "
                       & "a body sample");
      Put_Line ("  -hs    put in body sample the comment header "
                       & "from the spec");
      Put_Line ("  -hg    put in body sample a sample comment header");
      Put_Line ("  -Idir  source search dir, has the same meaning as for "
                       & "gcc and gnatmake");
      Put_Line ("  -I-    do not look for the sources in the default "
                       & "directory");
      Put_Line ("  -in    (n in 1 .. 9) number of spaces used for identation "
                       & "in a sample body");
      Put_Line ("  -k     do not remove the tree file");
      Put_Line ("  -ln    (n in 60 .. 999) maximum line length "
                       & "in a sample body");
      Put_Line ("  -q     quiet mode - do not confirm creating a body");
      Put_Line ("  -r     reuse the tree file (if any) instead of "
                       & "creating it");
      Put_Line ("         (-r also implies -k)");
      Put_Line ("  -t     overwrite the existing tree file");
      Put_Line ("  -v     verbose mode - output the version information");

   end Brief_Help;

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

   procedure Check_Parameters is
      Ind : Integer;

      I_Len : Natural;
      Next_Dir_Start : Natural := 2;
      Next_Dir_End : Natural := 2;
      --  "2 is because of the leading ' '  "
   begin

      --  Check that the argument file follows the GNAT file name conventions:
      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")
      then
         Put_Line ("gnatstub: " & File_Name.all &
                  " is not a name of a spec file");
         raise Parameter_Error;
      end if;

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

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

      --  and now, we have to compute some names before continuing checking:
      Ind := File_Name_First;

      for I in reverse File_Name_First .. File_Name_Last loop
         if File_Name (I) = Directory_Separator then
            Ind := I + 1;
            exit;
         end if;
      end loop;

      Short_File_Name := new String'(File_Name (Ind .. File_Name_Last));
      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 Destination_Dir = null 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';

      --  checking if a body already exists:

      if Is_Regular_File (Body_Name.all) then

         if Overwrite_Body then
            Open (Body_File, Out_File, Body_Name.all, Form);
            Delete (Body_File);
         else
            Put_Line ("gnatstub: the body for " & File_Name.all
                   & " already exists");
            Put_Line ("          use -f to overwrite it");
            raise Parameter_Error;
         end if;

      end if;

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

      Tree_Name (Tree_Name'Last)     := 't';
      Tree_Name (Tree_Name'Last - 1) := 'd';
      Tree_Name (Tree_Name'Last - 2) := 'a';

      if Is_Regular_File (Tree_Name.all) then
         Tree_Exists := True;
         if not (Reuse_Tree or else Overwrite_Tree) then
            Put_Line ("gnatstub: " & Tree_Name.all & " already exists");
            Put_Line ("           use -r or -t to reuse or to overwrite it");
            raise Parameter_Error;
         end if;
      else
         if Reuse_Tree then
            Put_Line ("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;

      --  now, converting '-I' options from a string into argument list

      if Dir_Count = 0 then
         Arg_List := new Argument_List (1 .. 0);
      else
         Arg_List := new Argument_List (1 .. Dir_Count);
         I_Len := I_Options'Length;
         for I in 1 .. Dir_Count loop
            while (Next_Dir_End <= I_Len and then
                   I_Options (Next_Dir_End) /= ' ')
            loop
               Next_Dir_End := Next_Dir_End + 1;
            end loop;
            Next_Dir_End := Next_Dir_End - 1;
            Arg_List (I) :=
               new String'(I_Options (Next_Dir_Start .. Next_Dir_End));
               Next_Dir_Start := Next_Dir_End + 2;
               Next_Dir_End := Next_Dir_Start;
         end loop;
      end if;

   --  Cleaning up - freeing what we will not need any more
      Free (Destination_Dir);
      Free (I_Options);
      Free (I_Options_Tmp);

   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 modifyed Tree_Name for this, because we do not need
         --  Tree_Name any more
         Tree_Name (Tree_Name'Last - 2 .. Tree_Name'Last) := "ali";
         Open (Tree_File, In_File, Tree_Name.all, Form);
         Delete (Tree_File);

      end if;

   end Clean_Up;

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

   procedure Create_Element_Node
     (Element : in     Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Body_State)
   is
      Arg_Kind : 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 let 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;
         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 = An_Incomplete_Type_Declaration then
               --  no need for alphabetical ordering, inserting in the
               --  very beginning:
               New_Node.Next := State.Current_List;
               State.Current_List.Prev := New_Node;
               State.Current_List      := New_Node;
            else
               Next_Node := State.Current_List;

               --  finding the right place in the current list
               loop

                  if Flat_Element_Kind (Next_Node.Spec) =
                     An_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;

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

      My_Context : Asis.Context;
      CU         : Asis.Compilation_Unit;
      CU_Kind    : Unit_Kinds;

      CU_Name_Len : Positive := Short_File_Name_Len - 4;
      --  "- 4" stands for ".ads"
      CU_Name : String (1 .. CU_Name_Len) :=
        Short_File_Name.all
          (Short_File_Name_First .. Short_File_Name_Last - 4);

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

      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.

      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;

   begin

      Asis.Implementation.Initialize;

      Associate
        (My_Context,
        "My_Context",
        "-C1 " & To_Wide_String (Tree_Name.all));

      Open (My_Context);

      Make_Unit_Name (CU_Name);
      CU := Library_Unit_Declaration (To_Wide_String (CU_Name), My_Context);

      if Is_Nil (CU) then
         --  this may be the case if the file name for which gnatstub was
         --  krunched. This is the case for the GNAT RTL components.
         --  In this case we have to iterate through the context
         declare
            C_Units : Asis.Compilation_Unit_List :=
               Asis.Compilation_Units.Compilation_Units (My_Context);
         begin
            --  to be 100% honest, we should go through C_Units list and
            --  to compare the result of Asis.Compilation_Units.Text_Name
            --  applied to a unit with File_Name. But here we use the
            --  fact, that in every tree a unit for which the tree is
            --  created is always processed first when ASIS opens a
            --  Context, and here in gnatstub we have C1 context. So
            --  the needed unit is the second in the list (just after Standard)

            if C_Units'Length > 1 then
               CU := C_Units (2);
            end if;

         end;
      end if;

      CU_Kind := Unit_Kind (CU);

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

      elsif not (CU_Kind = A_Procedure or else
                 CU_Kind = A_Function or else
                 CU_Kind = A_Generic_Procedure or else
                 CU_Kind = A_Generic_Function or else
                 ((CU_Kind = A_Package or else
                    CU_Kind = A_Generic_Package) and then
                   Asis.Compilation_Units.Is_Body_Required (CU)))
      then

         if not Quiet_Mode then
            Put      ("Compilation unit " & CU_Name);
            Put_Line (" does not require a body");
            Put_Line ("  Unit Kind: " & Unit_Kinds'Image (CU_Kind));
         end if;

         return;

      else
         --  and here we have to do the job:
         Create (Body_File, Out_File, Body_Name.all, Form);

         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      ("body is created for ");
               Put_Line (Gnatstub.Options.File_Name.all);
            end if;

         else
            Put      ("gnatstub: failed to write the comment header");
            Put_Line (" 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;

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

         Emergency_Clean_Up;

      when others =>
         Emergency_Clean_Up;
         raise;
   end Create_Sample;

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

   procedure Create_Tree is
      Success : Boolean := False;
   begin
      if Tree_Exists and then Reuse_Tree then
         return;
      end if;
      Compile (File_Name, Arg_List.all, Success);
      if not Success then
         Put_Line ("gnatstub: cannot create the tree file for "
                  & File_Name.all);
         raise Parameter_Error;
      else
         Tree_Exists := True;
      end if;
   end Create_Tree;

   -----------------------------
   -- 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 : 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 /= An_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 =>
               Gernerate_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 =>
               Generate_Full_Type_Declaration (Node);

            when others =>
               Put_Line ("gnatstub: unexpected element in the body structure");
               raise Program_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 & ";");
         New_Line (Body_File);

      end Print_Node_List;

   begin

      Print_Node (Body_Structure'Access);

   exception
      when Ex : others =>
         Raise_Exception
           (Exception_Identity (Ex),
           "Generate_Body_Structure failed");

   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            : String := "B o d y";
      Body_String_Len        : Positive := Body_String'Length;

      --  This local declarations are used to copy a comment header from the
      --  argument spec
      Spec_File              : File_Type;
      String_Buf             : String (1 .. Max_Body_Line_Length + 1);
      Spec_Line_Len          : Natural;
      Spec_String_Start      : Natural;

   begin
      Success := False;

      if Header = Stand_Header then
         --  first, checking how (and if) we can fit the maximum line length:

         if Unit_Name_Len + 6 > Max_Body_Line_Length then

            Put_Line ("gnatstub: argument unit name is too long "
                    & "to generate a comment header for the body");
            Put_Line ("gnatstub: try to increase the maximum body "
                    & "line length");

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

      elsif Header = From_Spec then

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

         while not End_Of_File (Spec_File) loop
            Get_Line (Spec_File, String_Buf, Spec_Line_Len);

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

            if Spec_Line_Len  > Max_Body_Line_Length then
               Put_Line ("gnatstub: too long line in spec's comment header");
               Put_Line ("gnatstub: try to increase "
                       & "the maximum body line length");

               Close (Spec_File);

               raise Parameter_Error;
            end if;

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

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

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

         end loop;

         Close (Spec_File);

      end if;

      Success := True;

   exception

      when Parameter_Error =>
         --  We use Parameter_Error as a means to jump out of the sequence of
         --  statements which creates a header. It is not a real exception
         --  situation for a whole program.
         --  Here we have a body file opened. There is no need to keep this
         --  broken body:
         Delete (Body_File);
      when Ex : others =>
         Raise_Exception (Exception_Identity (Ex),
                         "Generate_CU_Header failed");
   end Generate_CU_Header;

   --------------------------
   -- Gernerate_Entry_Body --
   --------------------------

   procedure Gernerate_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, "null;");

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

      New_Line (Body_File);

   end Gernerate_Entry_Body;

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

   procedure Generate_Full_Type_Declaration (Node : Link) is
      Discr_Part : Asis.Element := Discriminant_Part (Node.Spec);
   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,
              Trim (To_String (Element_Image (Discr_Part)), Both) & " ");
      end if;

      Put_Line (Body_File, "is null record;");

      New_Line (Body_File);

   end Generate_Full_Type_Declaration;

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

   procedure Generate_Function_Body (Node : Link) is
      Change_Line : Boolean;
      Parameters  : Asis.Element_List := Parameter_Profile (Node.Spec);
      First_Formal : Boolean := True;

      function Formals_To_Actuals
        (Formal_Names : Asis.Element_List)
         return String;
      --  this function returns a string of names of formal parameters
      --  separated with a comma, this list may be used as actuals in a
      --  dummy call to this function in the return statement which should
      --  be generated in the function body

      function Formals_To_Actuals
        (Formal_Names : Asis.Element_List)
         return String
      is
      begin
         if First_Formal then
            First_Formal := False;

            return To_String (Defining_Name_Image (Formal_Names
                               (Formal_Names'First))) &
              Formals_To_Actuals
                (Formal_Names (Formal_Names'First + 1 .. Formal_Names'Last));

         elsif Formal_Names'Length = 0 then

            return "";

         else

            return ", " & To_String (Defining_Name_Image (Formal_Names
                               (Formal_Names'First))) &
              Formals_To_Actuals
                (Formal_Names (Formal_Names'First + 1 .. Formal_Names'Last));
         end if;

      end Formals_To_Actuals;

   begin
      Set_Col  (Body_File, Positive_Count (1 + Level * Indent_Level));
      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;

      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));
      --  generating a dummy recursive call to itself:
      Put (Body_File, "return " & Node.Spec_Name.all);

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

         for I in Parameters'Range loop
            Put (Body_File, Formals_To_Actuals (Names (Parameters (I))));
         end loop;

         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_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));
      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, "null;");

      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 : Flat_Element_Kinds := Flat_Element_Kind (Node.Spec);
      Spec_Span : Span;
      Parameters : Asis.Element_List := Parameter_Profile (Node.Spec);
      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,
                 Trim (To_String (Element_Image (Family_Def)), Both));
            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,
                 Trim (To_String (Element_Image (Parameters (I))), Both));

            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;

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

      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, "null;");

      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 : Natural := Node.Spec_Name'Length + 6;
   begin
      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 Generate_Unit_Header;

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

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

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

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

   procedure Initialize is
      Next_Arg : Positive := 1;
   begin

      --  First, scanning the command line parameters:
      while Next_Arg <= Argument_Count loop
         Scan_Gnatstub_Arg (Argument (Next_Arg));
         Next_Arg := Next_Arg + 1;
      end loop;

      if Verbose_Mode then
         Put_Gnatstub_Version;
         New_Line;
         Put_Line ("Copyright 1997-2000, Free Software Foundation, Inc.");
         New_Line;
      end if;

      if Argument_Count = 0 or else
         File_Name = null
      then
         Brief_Help;
         --  Is_Initialized remains False here!
      else
         --  then, checking, that parameters are valid and that they
         --  corresponds to the situation in the file system

         Check_Parameters;
         Create_Tree;

         Initialized := True;
      end if;

   exception
      when Parameter_Error =>
         Initialized := False;
         --  noting else to do!
      when others =>
         Initialized := False;
         raise;
   end Initialize;

   --------------------
   -- Make_Unit_Name --
   --------------------

   procedure Make_Unit_Name (CU_Name : in out String) is
   begin
      for I in CU_Name'Range loop
         if CU_Name (I) = '-' then
            CU_Name (I) := '.';
         end if;
      end loop;
   end Make_Unit_Name;

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

   function Name (El : Asis.Element) return String is
      Def_Name : Asis.Element := Names (El) (1);
      Def_Name_String : 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 ("GNATSTUB (built with ");
      Put (To_String (Asis.Implementation.ASIS_Implementor_Version));
      Put (")");
   end Put_Gnatstub_Version;

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

   function Requires_Body (El : Element) return Boolean is
      Arg_Kind     : 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 =>
            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 implemements the temporary solution
               --  ??? for subprograms completed by pragmas Import.
               --  ??? it should be revised when Asis.ExtensionsIs_Completed
               --  ??? dets 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_Arg --
   -----------------------

   procedure Scan_Gnatstub_Arg (Argv : String) is
      First            : Integer := Argv'First;
      Len              : Natural := Argv'Length;
      Switch_Parameter : Natural;

      function Get_Switch_Parameter (Val : String) return Natural;
      --  computes a natural parameter for switch from its string
      --  representation. Raises Parameter_Error if Val can not be considered
      --  as a string image of a natural number. This function supposes that
      --  Val is not an empty string.

      function Get_Switch_Parameter (Val : String) return Natural is
         Result : Natural := 0;
      begin
         for I in Val'Range loop

            if Val (I) not in '0' .. '9' then
               Put_Line ("gnatstub: wrong switch integer parameter " & Val);
               raise Parameter_Error;
            else
               Result := Result * 10 +
                  Character'Pos (Val (I)) - Character'Pos ('0');
            end if;

         end loop;

         return Result;

      end Get_Switch_Parameter;

   begin
      if Len = 0 then
         return;
      end if;

      if Argv (First) = '-' then

         if Len >= 2 then

            case Argv (First + 1) is
               when 'f' =>

                  if Argv = "-f" then
                     Overwrite_Body := True;
                  else
                     Unknown_Option (Argv);
                  end if;

               when 'h' =>

                  if Argv = "-hs" then
                     Header := From_Spec;
                  elsif Argv = "-hg" then
                     Header := Stand_Header;
                  else
                     Unknown_Option (Argv);
                  end if;

               when 'i' =>

                  if Len = 2 then
                     Put_Line ("gnatstub: missed value for -i parameter");
                     raise Parameter_Error;
                  end if;

                  Switch_Parameter :=
                     Get_Switch_Parameter (Argv (First + 2 .. Argv'Last));

                  Indent_Level := Switch_Parameter;

               when 'k' =>

                  if Argv = "-k" then
                     Delete_Tree := False;
                  else
                     Unknown_Option (Argv);
                  end if;

               when 'l' =>

                  if Len = 2 then
                     Put_Line ("gnatstub: missed value for -l parameter");
                     raise Parameter_Error;
                  end if;

                  Switch_Parameter :=
                     Get_Switch_Parameter (Argv (First + 2 .. Argv'Last));

                  if Switch_Parameter = 0 then
                     Put      ("gnatstub: body line length can not be 0 (");
                     Put      (Argv);
                     Put_Line (")");
                     raise Parameter_Error;
                  else
                     Max_Body_Line_Length := Switch_Parameter;
                  end if;

               when 'q' =>

                  if Argv = "-q" then
                     Quiet_Mode := True;
                  else
                     Unknown_Option (Argv);
                  end if;

               when 'r' =>

                  if Argv = "-r" then
                     Reuse_Tree := True;
                  else
                     Unknown_Option (Argv);
                  end if;

               when 't' =>

                  if Argv = "-t" then
                     Overwrite_Tree := True;
                  else
                     Unknown_Option (Argv);
                  end if;

               when 'v' =>

                  if Argv = "-v" then
                     Verbose_Mode := True;
                  else
                     Unknown_Option (Argv);
                  end if;

               when 'I' =>
                  Free (I_Options_Tmp);
                  I_Options_Tmp := new String'(I_Options.all & " " & Argv);
                  Free (I_Options);
                  I_Options := new String'(I_Options_Tmp.all);
                  Dir_Count := Dir_Count + 1;

               when others =>
                  Unknown_Option (Argv);
            end case;
         else
            Unknown_Option (Argv);
         end if;

      else

         --  ether a file name or a destination
         if File_Name = null then
            File_Name := new String'(Argv);
         elsif Destination_Dir = null then
            Destination_Dir := new String'(Argv);
         else
            Put      ("gnatstub: only one file name and at most one ");
            Put_Line ("destination directory are allowed");
            raise Parameter_Error;
         end if;

      end if;

   end Scan_Gnatstub_Arg;

   --------------------
   -- Unknown_Option --
   --------------------

   procedure Unknown_Option (Argv : String) is
   begin
      Put_Line ("gnatstub: unknown option " & Argv);
      raise Parameter_Error;
   end Unknown_Option;

end Gnatstub.Sampler;
