--
--  Copyright (C) 2011, AdaCore
--

--
--  This is a test procedure for name hashing function of gnattest.
--  It takes a number of source files as it's arguments, looks through those
--  containing package specifications and computes hash for each subprogram
--  declaration found. In case that some hash names are clashing, the list
--  of subprograms and their locations sharing same hash name is printed
--  to the standard error stream.
--  Prints the total number of computed hashes to standard output after
--  execution.
--
--  Usage:
--
--   gnattest_hash_testing [options] {filename} {-files filename}
--     [-cargs switches]
--
--  options:
--
--   -h               - print help message
--   -v               - verbose mode
--   --files=filename - name of the text file containing a list of Ada source
--                      files for which harness should be generated
--

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

with GNAT.OS_Lib;                use GNAT.OS_Lib;

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

with GNAT.Command_Line;          use GNAT.Command_Line;
with GNAT.Directory_Operations;  use GNAT.Directory_Operations;

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

with GNATtest.Stub.Generator;

with Ada.Containers.Indefinite_Ordered_Maps;
with Ada.Containers.Indefinite_Ordered_Sets;

procedure GNATtest_Hash_Testing is

   Subp_Counter  : Natural := 0;
   Clash_Counter : Natural := 0;

   Verbose : Boolean := False;

   --  Storing results part
   type Subp_Info is record
      Line      : Integer;
      Row       : Integer;
      Subp_Name : String_Access;
      File_Name : String_Access;
   end record;

   type Subp_Info_Elem;

   type Subp_Info_Access is access all Subp_Info_Elem;

   type Subp_Info_Elem is record
      Info : Subp_Info;
      Next : Subp_Info_Access := null;
   end record;

   type Position is record
      Hash     : String_Access;
      Position : String_Access;
   end record;

   function "<" (Left, Right : Position) return Boolean;

   package Hash_Coll is new
     Ada.Containers.Indefinite_Ordered_Maps
       (Position, Subp_Info_Elem, "<");
   use Hash_Coll;

   Coll     : Hash_Coll.Map;
   Coll_Ptr : Hash_Coll.Cursor;

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

   ST     : Source_Table.Set;
   ST_Ptr : Source_Table.Cursor;

   --  Other stuff

   Arg      : String_Access;
   Temp_Dir : String_Access;

   Elem     : Subp_Info_Elem;
   Elem_Ptr : Subp_Info_Access;

   The_Context : Asis.Context;
   --  The Context for all the processing. May be associated, opened, closed
   --  and dissociated several times during one tool run.

   Last_Context_Name : String_Access;
   Successful_Initialization : Boolean;

   Parameter_Error, Fatal_Error : exception;

   ----------------
   -- Traversing --
   ----------------

   The_Unit : Asis.Compilation_Unit;

   Control : Traverse_Control := Continue;

   Dummy_State : No_State := Not_Used;

   procedure Pre_Operation
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out No_State);

   procedure Get_Subprograms is new Traverse_Element
     (Pre_Operation     => Pre_Operation,
      Post_Operation    => No_Op,
      State_Information => No_State);
   --  Sets the vulue of Main_Type with the first tagged record element
   --  and checks that there's no more tagged records in the given unit.

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

   -----------------------
   -- Inner Subprograms --
   -----------------------

   procedure Report_Err (Message : String);
   procedure Report_Std (Message : String);
   procedure Brief_Help;

   procedure Report_Unhandled_ASIS_Exception (Ex : Exception_Occurrence);
   --  Reports an unhandled ASIS exception

   procedure Read_Args_From_File (Par_File_Name : String);
   --  Reads argument files from the file. Performs the same checks as when
   --  file names are read from the command line. This procedure assumes that
   --  the file named by Par_File_Name contains argument file names separated
   --  by one or more spaces.

   procedure Create_Temp_Dir;
   --  Creates the temporary directory and stores its name in Temp_Dir.

   function Initialize_Context (Source_Name : String) return Boolean;
   --  Creates a tree file and initializes the context.

   procedure Source_Clean_Up;
   --  Minimal clean-up needed for one source (deleting .ali & .adt)

   procedure Context_Clean_Up;
   --  Closes and dissociates the context, if needed

   procedure Clean_Up;
   --  Performs the final clean-up actions, including closing and deleting of
   --  all files that should be closed or deleted.

   procedure Create_Tree (Full_Source_Name : String; Success : out Boolean);
   --  Tries to create the tree file for the given source file. The tree file
   --  and the corresponding ALI file are placed into a temporary directory.
   --  If the attempt is successful, Success is set ON, otherwise it is set
   --  OFF.

   -------------------
   -- Pre_Operation --
   -------------------
   procedure Pre_Operation
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out No_State)
   is
      pragma Unreferenced (Control);
      pragma Unreferenced (State);

      Subp_Name : String_Access;
      Pos       : Position;

      Insert_Point : Subp_Info_Access;
      Insertion    : Subp_Info;
      Elem         : Subp_Info_Elem;
   begin

      if Element_Kind (Element) = A_Declaration then

         case Declaration_Kind (Element) is

            when A_Protected_Type_Declaration   |
                 A_Single_Protected_Declaration =>
               Control := Abandon_Children;

            when A_Procedure_Declaration |
                 A_Function_Declaration =>

               Subp_Counter := Subp_Counter + 1;

               Subp_Name := new String'
                 (To_String (Defining_Name_Image (First_Name (Element))));

               Pos.Hash := new String'
                 (GNATtest.Stub.Generator.Mangle_Hash
                    (Element, Asis.Nil_Element));

               Pos.Position := new String'(Get_Nesting (Element));

               Insertion.Line := Element_Span (Element).First_Line;
               Insertion.Row  := Element_Span (Element).First_Column;

               Insertion.Subp_Name := new String'(Subp_Name.all);
               Insertion.File_Name := new String'
                 (Normalize_Pathname
                    (Name           => To_String (Text_Name (The_Unit)),
                     Case_Sensitive => False));

               Report_Std
                 (Insertion.Subp_Name.all & " at "                     &
                  Trim (Integer'Image (Insertion.Line), Both) & ":"    &
                  Trim (Integer'Image (Insertion.Row), Both)  & " in " &
                  Insertion.File_Name.all & " hash: "                  &
                  Pos.Hash.all);

               if Coll.Find (Pos) = Hash_Coll.No_Element then
                  Coll.Insert
                    (Pos,
                     (Info => Insertion,
                      Next => null));
               else
                  if Coll.Element (Pos).Next = null then
                     Elem := Coll.Element (Pos);
                     Elem.Next := new Subp_Info_Elem'
                       (Info => Insertion, Next => null);
                     Coll.Replace (Pos, Elem);

                  else

                     Insert_Point := Coll.Element (Pos).Next;
                     loop
                        if Insert_Point.all.Next = null then

                           Insert_Point.all.Next := new Subp_Info_Elem'
                             (Info => Insertion, Next => null);
                           exit;
                        else
                           Insert_Point := Insert_Point.all.Next;
                        end if;

                     end loop;

                  end if;

                  Clash_Counter := Clash_Counter + 1;

               end if;

            when others =>
               null;
         end case;

      end if;

   end Pre_Operation;

   function Get_Nesting (Elem : Asis.Element) return String is
      Res  : String_Access := new String'("");
      Buff : String_Access;

      Enclosing : Asis.Element;
   begin

      Enclosing := Enclosing_Element (Elem);

      loop

         exit when Is_Nil (Enclosing);

         if Res.all = "" then
            Free (Res);
            Res := new String'
              (To_String (Defining_Name_Image
               (First_Name (Enclosing))));
         else
            Buff :=
              new String'(To_String (Defining_Name_Image
                (First_Name (Enclosing))) &
                "." & Res.all);
            Free (Res);
            Res := new String'(Buff.all);
            Free (Buff);
         end if;

         Enclosing := Enclosing_Element (Enclosing);

      end loop;

      return Res.all;

   end Get_Nesting;

   function "<" (Left, Right : Position) return Boolean is
   begin

      if Left.Hash.all < Right.Hash.all then
         return True;
      end if;

      if Left.Hash.all = Right.Hash.all then
         if Left.Position.all < Right.Position.all then
            return True;
         end if;
      end if;

      return False;

   end "<";

   ----------------
   -- Report_Err --
   ----------------

   procedure Report_Err (Message : String) is
   begin
      Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, Message);
   end Report_Err;

   ----------------
   -- Report_Std --
   ----------------

   procedure Report_Std (Message : String) is
   begin

      if not Verbose then
         return;
      end if;

      Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Output, Message);
   end Report_Std;

   -------------------------------------
   -- Report_Unhandled_ASIS_Exception --
   -------------------------------------
   procedure Report_Unhandled_ASIS_Exception (Ex : Exception_Occurrence) is
   begin
      Report_Err ("ASIS exception (" & Exception_Name (Ex) & ") is raised");
      Report_Err ("ASIS Error Status is " & Status'Img);
      Report_Err ("ASIS Diagnosis is " & To_String (Diagnosis));

      Set_Status;
   end Report_Unhandled_ASIS_Exception;

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

   procedure Brief_Help is
   begin
      Put_Line
        ("usage:");
      Put_Line ("");
      Put_Line
        (" gnattest_hash_testing [options] {filename} {-files filename} " &
         "[-cargs switches]");
      Put_Line ("");
      Put_Line ("options:");
      Put_Line ("");
      Put_Line (" -h               - print help message");
      Put_Line (" -v               - verbose mode");
      Put_Line (" --files=filename - " &
                "name of the text file containing a list of Ada source");
      Put_Line ("                    " &
                "files for which harness should be generated");
      Put_Line ("");
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success);
   end Brief_Help;

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

   procedure Create_Tree (Full_Source_Name : String; Success : out Boolean) is
   begin
      Compile
       (new String'(Full_Source_Name),
        Arg_List.all,
        Success,
        GCC => ASIS_UL.Common.Gcc_To_Call);
   end Create_Tree;

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

   procedure Clean_Up is
   begin
      Context_Clean_Up;

      --  Cleaning up temporary dir

      if Temp_Dir /= null then
         if not Is_Directory (Temp_Dir.all) then
            --  We may be inside this temporary directory
            Change_Dir ("..");
         end if;

         begin
            Remove_Dir (Temp_Dir.all, Recursive => True);
         exception
            when Directory_Error =>
               Free (Temp_Dir);  -- to avoid cycling
               Report_Err
                 ("gnattest_hash_testing: cannot remove temporary directory");
               raise Fatal_Error;
         end;

         Free (Temp_Dir);
      end if;
   end Clean_Up;

   ----------------------
   -- Context_Clean_Up --
   ----------------------

   procedure Context_Clean_Up is
   begin
      if Is_Open (The_Context) then
         Close (The_Context);
      end if;

      if Has_Associations (The_Context) then
         Dissociate (The_Context);
      end if;
   end Context_Clean_Up;

   -------------------------
   -- Read_Args_From_File --
   -------------------------

   procedure Read_Args_From_File (Par_File_Name : String) is

      Arg_File         : File_Type;
      File_Name_Buffer : String (1 .. 16 * 1024);
      File_Name_Len    : Natural := 0;
      Next_Ch          : Character;
      End_Of_Line      : Boolean;

      function Get_File_Name return String;
      --  Reads from Par_File_Name the name of the next file (the file to read
      --  from should exist and be opened). Returns an empty string if there is
      --  no file names in Par_File_Name any more

      -------------------
      -- Get_File_Name --
      -------------------

      function Get_File_Name return String is
      begin
         File_Name_Len := 0;

         if not End_Of_File (Arg_File) then
            Get (Arg_File, Next_Ch);

            while Next_Ch = ' ' loop
               exit when End_Of_File (Arg_File);
               Get (Arg_File, Next_Ch);
            end loop;

            while Next_Ch /= ' ' loop
               File_Name_Len := File_Name_Len + 1;
               File_Name_Buffer (File_Name_Len) := Next_Ch;

               Look_Ahead (Arg_File, Next_Ch, End_Of_Line);

               exit when End_Of_Line or else End_Of_File (Arg_File);

               Get (Arg_File, Next_Ch);
            end loop;
         end if;

         return File_Name_Buffer (1 .. File_Name_Len);
      end Get_File_Name;

   begin
      if not Is_Regular_File (Par_File_Name) then
         Report_Err
           ("gnattest_hash_testing: " & Par_File_Name & " does not exist");
         return;
      end if;

      Open (Arg_File, In_File, Par_File_Name);

      loop
         Arg := new String'(Get_File_Name);
         exit when Arg.all = "";
         ST.Include
           (Normalize_Pathname
              (Name           => Arg.all,
               Case_Sensitive => False));
         Free (Arg);
      end loop;
      Free (Arg);

      Close (Arg_File);

   exception
      when others =>
         Report_Err
           ("gnattest_hash_testing: cannot read arguments from " &
            Par_File_Name);
         raise;
   end Read_Args_From_File;

   ---------------------
   -- Create_Temp_Dir --
   ---------------------

   procedure Create_Temp_Dir is
      FD        : File_Descriptor;
      Temp_Name : Temp_File_Name;
      Success   : Boolean;

   begin
      --  Here we use exactly the same approach as in gnatelim

      --  ??? We create the temp dir by first creating the temp file, then
      --  closing and deleting it, then creating a dir with the same name.
      --  This is not atomary as another program can sneak in between file
      --  deletion and dir creation and snatch this name for itself. This is
      --  quite unlikely and anyway we don't have any other system-independent
      --  way at the moment
      Create_Temp_File (FD, Temp_Name);
      Close (FD);
      Delete_File (Temp_Name, Success);

      if not Success then
         Report_Err
           ("gnattest_hash_testing: cannot delete the temporary file" &
            " that was just created");

         raise Fatal_Error;
      end if;

      Make_Dir (Temp_Name);

      Temp_Dir :=
        new String'(Temp_Name (Temp_Name'First .. Temp_Name'Last - 1));

   exception
      when Directory_Error =>
         Report_Err
           ("gnattest_hash_testing: cannot create the temporary directory");
         raise Fatal_Error;
   end Create_Temp_Dir;

   ------------------------
   -- Initialize_Context --
   ------------------------

   function Initialize_Context (Source_Name : String) return Boolean is
      Success : Boolean;

      use type Asis.Errors.Error_Kinds; --  for EC12-013
   begin
      Create_Tree (Source_Name, Success);

      if not Success then

         Report_Err ("has_test: " & Source_Name &
                     " is not a legal Ada source");

         return False;

      end if;

      Last_Context_Name :=
        new String'(Base_Name (Source_Name, File_Extension (Source_Name)));

      Associate
       (The_Context => The_Context,
        Name        => "",
        Parameters  => "-C1 "
        & To_Wide_String
          (Base_Name (Source_Name, File_Extension (Source_Name)) & ".adt"));

      begin
         Open (The_Context);
         Success := True;
      exception
         when ASIS_Failed =>
            --  The only known situation when we can not open a C1 context for
            --  newly created tree is recompilation of System (see D617-017)

            if Asis.Implementation.Status = Asis.Errors.Use_Error
              and then
               Asis.Implementation.Diagnosis = "Internal implementation error:"
               & " Asis.Ada_Environments.Open - System is recompiled"
            then
               Report_Err
                 ("gnattest_hash_testing: can not process redefinition " &
                  "of System in " & Source_Name);

               Success := False;
            else
               raise;
            end if;

      end;

      return Success;
   end Initialize_Context;

   ---------------------
   -- Source_Clean_Up --
   ---------------------

   procedure Source_Clean_Up is
      Success : Boolean;
   begin
      if Last_Context_Name = null then
         return;
      end if;

      Delete_File (Last_Context_Name.all & ".adt", Success);
      if not Success then
         Report_Err ("gnattest_hash_testing: cannot delete " &
                     Last_Context_Name.all & ".adt");
      end if;

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

      Free (Last_Context_Name);
   end Source_Clean_Up;

begin

   Initialize_Option_Scan
        (Stop_At_First_Non_Switch => True,
         Section_Delimiters       => "cargs");

   loop
      case GNAT.Command_Line.Getopt
        ("-files= d? h v")
      is
         when ASCII.NUL =>
            exit;

         when 'd' =>
            if Full_Switch = "d" then
               Set_Debug_Options (Parameter);
            end if;

         when 'h' =>
            if Full_Switch = "h" then
               Brief_Help;
               Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success);
               return;
            end if;

         when 'v' =>
            if Full_Switch = "v" then
               Verbose := True;
            end if;

         when '-' =>
            if Full_Switch = "-files" then
               Read_Args_From_File (Parameter);
            end if;

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

   loop
      Arg := new String'(Get_Argument);
      exit when Arg.all = "";
      ST.Include
        (Normalize_Pathname
           (Name           => Arg.all,
            Case_Sensitive => False));
      Free (Arg);
   end loop;
   Free (Arg);

   Create_Temp_Dir;
   Change_Dir (Temp_Dir.all);

   Process_cargs_Section;
   Process_ADA_PRJ_INCLUDE_FILE;
   Store_I_Options;
   Set_Arg_List;

   if ST.Is_Empty then
      Report_Err ("gnattest_hash_testing: no argument sources");
      raise Fatal_Error;
   end if;

   ST_Ptr := ST.First;
   loop
      exit when ST_Ptr = Source_Table.No_Element;

      if not Is_Regular_File (Source_Table.Element (ST_Ptr)) then
            Report_Err
              ("gnattest_hash_testing: " & Source_Table.Element (ST_Ptr) &
               " not found");
      else
         Asis.Implementation.Initialize ("-asis05 -ws");

         Successful_Initialization :=
           Initialize_Context (Source_Table.Element (ST_Ptr));

         if Successful_Initialization then

            The_Unit := Main_Unit_In_Current_Tree (The_Context);

            case Declaration_Kind (Unit_Declaration (The_Unit)) is

            when A_Package_Declaration         |
                 A_Generic_Package_Declaration =>

               Get_Subprograms
                 (Unit_Declaration (The_Unit), Control, Dummy_State);

            when others => null;

            end case;

         end if;

         Source_Clean_Up;
         Context_Clean_Up;

         Asis.Implementation.Finalize;
      end if;

      Source_Table.Next (ST_Ptr);
   end loop;

   Clean_Up;

   Coll_Ptr := Coll.First;
   loop
      exit when Coll_Ptr = Hash_Coll.No_Element;

      if Hash_Coll.Element (Coll_Ptr).Next /= null then
         Report_Err ("gnattest_hash_testing: clash found");
         Elem := Hash_Coll.Element (Coll_Ptr);
         Elem_Ptr := Elem.Next;
         Report_Err
           (" " & Elem.Info.Subp_Name.all & " at "               &
            Trim (Integer'Image (Elem.Info.Line), Both) & ":"    &
            Trim (Integer'Image (Elem.Info.Row), Both)  & " in " &
            Elem.Info.File_Name.all);

         loop
            exit when Elem_Ptr = null;

            Report_Err
              (" " & Elem_Ptr.all.Info.Subp_Name.all & " at "               &
               Trim (Integer'Image (Elem_Ptr.all.Info.Line), Both) & ":"    &
               Trim (Integer'Image (Elem_Ptr.all.Info.Row), Both)  & " in " &
               Elem_Ptr.all.Info.File_Name.all);

            Elem_Ptr := Elem_Ptr.all.Next;

         end loop;

         Report_Err
           (" share same hash value: " & Hash_Coll.Key (Coll_Ptr).Hash.all);

      end if;

      Hash_Coll.Next (Coll_Ptr);
   end loop;

   Ada.Text_IO.Put_Line
     (Ada.Text_IO.Standard_Output,
      "Total number of hash computed:" & Natural'Image (Subp_Counter));

   Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success);

exception
   when GNAT.Command_Line.Invalid_Switch =>
         Report_Err
           ("gnattest_hash_testing: invalid switch : " & Full_Switch);
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

   when GNAT.Command_Line.Invalid_Parameter =>
         Report_Err
           ("gnattest_hash_testing: missing parameter for: -" & Full_Switch);
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

   when Fatal_Error =>
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      Clean_Up;

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

      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      Report_Unhandled_ASIS_Exception (Ex);
      Clean_Up;

   when Ex : others =>
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      Report_Err (Exception_Information (Ex));
      Clean_Up;

end GNATtest_Hash_Testing;
