------------------------------------------------------------------------------
--                                                                          --
--                           GNATTEST COMPONENTS                            --
--                                                                          --
--                      G N A T T E S T . C O M M O N                       --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2011-2013, AdaCore                     --
--                                                                          --
-- GNATTEST  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.  GNATTEST  is  distributed  in the hope that it will be useful, --
-- but  WITHOUT  ANY  WARRANTY;   without  even  the  implied  warranty  of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public License distributed with GNAT; see file COPYING. If --
-- not, write to the  Free  Software  Foundation, 51 Franklin Street, Fifth --
-- Floor, Boston, MA 02110-1301, USA.,                                      --
--                                                                          --
-- GNATTEST is maintained by AdaCore (http://www.adacore.com).              --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling;     use Ada.Characters.Handling;

with Asis;                       use Asis;
with Asis.Declarations;          use Asis.Declarations;
with Asis.Definitions;           use Asis.Definitions;
with Asis.Elements;              use Asis.Elements;
with Asis.Extensions;            use Asis.Extensions;
with Asis.Exceptions;            use Asis.Exceptions;
with Asis.Implementation;        use Asis.Implementation;

with GNAT.Directory_Operations;   use GNAT.Directory_Operations;

with GNATtest.Options;            use GNATtest.Options;

package body GNATtest.Common is

   -----------------
   -- Create_Dirs --
   -----------------

   procedure Create_Dirs (Target_Dirs : File_Array_Access) is
      First : Integer;
   begin
      for J in Target_Dirs'Range loop
         declare
            Target_Dir : constant String :=
                           Target_Dirs.all (J).Display_Full_Name;
         begin
            First := Target_Dir'First;

            if Is_Regular_File (Target_Dir) then
               Report_Err ("gnattest: cannot create dir " & Target_Dir);
               raise Fatal_Error;
            end if;

            for Idx in Target_Dir'Range loop
               if Target_Dir (Idx) = Directory_Separator
                 or else Idx = Target_Dir'Last
               then
                  if not Is_Directory (Target_Dir (First .. Idx)) then
                     begin
                        Make_Dir (Target_Dir (First .. Idx));
                     exception
                        when Directory_Error =>
                           Report_Err ("gnattest: cannot create dir " &
                                       Target_Dir (First .. Idx));
                           raise Fatal_Error;
                     end;
                  end if;
               end if;
            end loop;
         end;
      end loop;
   end Create_Dirs;

   --------------------------
   -- Generate_Common_File --
   --------------------------

   procedure Generate_Common_File is
      Common_Package_Name : constant String := "Gnattest_Generated";
      Common_File_Subdir  : constant String :=
        Harness_Dir.all & Directory_Separator & "common";
   begin
      if not Is_Directory (Common_File_Subdir) then
         Make_Dir (Common_File_Subdir);
      end if;
      Create (Output_File,
              Out_File,
              Common_File_Subdir &
              Directory_Separator &
              Unit_To_File_Name (Common_Package_Name) & ".ads");

      S_Put (0, "package Gnattest_Generated is");
      New_Line (Output_File);
      S_Put (3, "package GNATtest_Standard renames Standard;");
      New_Line (Output_File);
      S_Put (3, "Default_Assert_Value : Boolean := ");
      if Skeletons_Fail then
         S_Put (0, "False;");
      else
         S_Put (0, "True;");
      end if;
      New_Line (Output_File);
      S_Put (0, "end Gnattest_Generated;");

      Close (Output_File);
   end Generate_Common_File;

   -----------------
   -- Get_Nesting --
   -----------------

   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);
         if Declaration_Kind (Enclosing) = A_Package_Instantiation then
            Enclosing := Enclosing_Element (Enclosing);
         end if;

      end loop;

      return Res.all;

   end Get_Nesting;

   -------------------------
   -- First_Column_Number --
   -------------------------

   function First_Column_Number (Element : Asis.Element) return Line_Number is
      Sp : Asis.Text.Span;
   begin

      if Is_Text_Available (Element) then
         Sp := Element_Span (Element);

         return Sp.First_Column;

      else

         return 0;

      end if;

   end First_Column_Number;

   -------------------------------
   --  Parent_Type_Declaration  --
   -------------------------------

   function Parent_Type_Declaration
     (Type_Dec : Asis.Element) return Asis.Element
   is
      Dec_Elem : Asis.Element := Type_Dec;
      Def_Elem : Asis.Element := Type_Declaration_View (Dec_Elem);
   begin

      if
        Declaration_Kind (Dec_Elem) = A_Tagged_Incomplete_Type_Declaration
      then
         Dec_Elem := Corresponding_Type_Completion (Dec_Elem);
         Def_Elem := Type_Declaration_View (Dec_Elem);
      end if;

      if Declaration_Kind (Dec_Elem) = A_Private_Type_Declaration then
         Dec_Elem := Corresponding_Type_Declaration (Dec_Elem);
         Def_Elem := Type_Declaration_View (Dec_Elem);
      end if;

      if
        Definition_Kind (Def_Elem) = A_Private_Extension_Definition
      then

         Dec_Elem := Corresponding_Type_Declaration (Dec_Elem);
         Def_Elem := Type_Declaration_View (Dec_Elem);
      end if;

      Dec_Elem := Corresponding_Parent_Subtype (Def_Elem);

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

      return Dec_Elem;

   exception

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

   end Parent_Type_Declaration;

   ------------------------
   -- Put_Harness_Header --
   ------------------------

   procedure Put_Harness_Header is
   begin
      S_Put
        (0,
         "--  This package has been generated automatically by GNATtest.");
      New_Line (Output_File);
      S_Put
        (0,
         "--  Do not edit any part of it, "
         & "see GNATtest documentation for more details.");
      New_Line (Output_File);
      New_Line (Output_File);
   end Put_Harness_Header;

   ------------------------
   -- Report_AUnit_Usage --
   ------------------------

   procedure Report_AUnit_Usage is
   begin
      Report_Err ("gnattest: trying to process aunit itself!");
      Report_Err ("gnattest: Fatal_Error raised, terminating process.");
   end Report_AUnit_Usage;

   ----------------
   -- 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; Offset : Integer := 0) is
   begin

      if GNATtest.Options.Quiet then
         return;
      end if;

      for I in 1 .. Offset loop
         Ada.Text_IO.Put (Ada.Text_IO.Standard_Output, " ");
      end loop;

      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;

   --------------------------------
   -- Report_Unhandled_Exception --
   --------------------------------

   procedure Report_Unhandled_Exception (Ex : Exception_Occurrence) is
   begin
      Report_Err (Exception_Information (Ex));
   end Report_Unhandled_Exception;

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

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

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

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

      return To_Lower (T.all);
   end Unit_To_File_Name;

end GNATtest.Common;
