------------------------------------------------------------------------------
--                                                                          --
--                            GNATPP COMPONENTS                             --
--                                                                          --
--                    G N A T P P . P R O C E S S I N G                     --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2001-2007, AdaCore                     --
--                                                                          --
-- GNATPP is free software; you can redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNATPP is  distributed in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY; without even the implied warranty of  MERCHANTABI- --
-- LITY 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.                                              --
--                                                                          --
-- GNATPP is maintained by AdaCore (http://www.adacore.com)                 --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling;         use Ada.Characters.Handling;
with Ada.Text_IO;                     use Ada.Text_IO;
with Ada.Wide_Text_IO;
with Ada.Unchecked_Deallocation;

with GNAT.OS_Lib;                     use GNAT.OS_Lib;
with Hostparm;

with Asis.Compilation_Units;          use Asis.Compilation_Units;
with Asis.Elements;                   use Asis.Elements;
with Asis.Exceptions;
with Asis.Extensions;                 use Asis.Extensions;
with Asis.Extensions.Flat_Kinds;      use Asis.Extensions.Flat_Kinds;
with Asis.Implementation;
with Asis.Text;                       use Asis.Text;

with ASIS_UL.Common;                  use ASIS_UL.Common;
with ASIS_UL.Options;

with GNATPP.Comments;                 use GNATPP.Comments;
with GNATPP.Common;                   use GNATPP.Common;
with GNATPP.Environment;              use GNATPP.Environment;
with GNATPP.General_Traversal_Stacks; use GNATPP.General_Traversal_Stacks;
with GNATPP.Layout;                   use GNATPP.Layout;
with GNATPP.Options;                  use GNATPP.Options;
with GNATPP.Output;                   use GNATPP.Output;
with GNATPP.Paragraphs;               use GNATPP.Paragraphs;
with GNATPP.PP_Output;                use GNATPP.PP_Output;
with GNATPP.Source_Traversal;         use GNATPP.Source_Traversal;
with GNATPP.State;                    use GNATPP.State;
with GNATPP.Utilities;                use GNATPP.Utilities;

package body GNATPP.Processing is

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

   procedure Prepare_Context (SF : SF_Id; Success : out Boolean);
   --  Opens the ASIS Context from that all the information will be extracted.
   --  This includes tree creation (or compilation on the fly in GNSA version).
   --  Success is set ON if the Context is successfully opened after creating
   --  the tree.

   procedure Process_Sources (Only_Bodies : Boolean := False);
   --  Processes sources stores in the sources table trying to minimize
   --  compilations needed to create the tree files. If Only_Bodies is set ON,
   --  only files with .adb suffixes are compiled for the trees.

   procedure Process_Main_Source (SF : SF_Id);
   --  Processes the source file stored under SF index into source file table.
   --  The caller is responsible to keep the actual parameter inside the
   --  range of the existing table entries. The processing consists of
   --  creating the tree file for this source, and if the tree is successfully
   --  created, then the source text is reformatted for the main unit in this
   --  tree. Then gnatpp tries to process all the non-processed
   --  sources which can be processed on the base of this tree. When all
   --  possible sources are processed, the tree file is deleted from the
   --  temporary directory.

   procedure Output_Source (SF : SF_Id);
   --  Output into Stderr the tracing information about SF. This procedure
   --  decreases the counter of the sources which have to be processed
   --  (Sources_Left)

   ----------
   -- Main --
   ----------

   procedure Main is
   begin
      if ASIS_UL.Options.ASIS_2005_Mode then
         Asis.Implementation.Initialize ("-asis05 -ws -k");
      else
         Asis.Implementation.Initialize ("-ws");
      end if;

      Process_Sources (Only_Bodies => True);
      Process_Sources;

      Asis.Implementation.Finalize;
   end Main;

   -------------------
   -- Output_Source --
   -------------------

   procedure Output_Source (SF : SF_Id) is
      N : constant String := Natural'Image (Sources_Left);
   begin

      if not Multiple_File_Mode then
         return;
      end if;

      if Progress_Indicator_Mode then
         declare
            Current : constant Integer := Total_Sources - Sources_Left + 1;
            Percent : String :=
              Integer'Image ((Current * 100) / Total_Sources);
         begin
            Percent (1) := '(';
            Put_Line (Standard_Output,
                     "completed" & Integer'Image (Current) & " out of"
                    & Integer'Image (Total_Sources) & " "
                    & Percent & "%)...");
         end;
      end if;

      if Verbose_Mode then
         Put_Line
           (Standard_Error,
           "[" & N (2 .. N'Last) & "]  " & Short_Source_Name (SF));

      elsif not (Quiet_Mode or Progress_Indicator_Mode) then
         Put (Standard_Error, "Units remaining:");
         Put (Standard_Error, N);
         Put (Standard_Error, "     ");
         Put (Standard_Error, (1 => ASCII.CR));
      end if;

      Sources_Left := Sources_Left - 1;

   end Output_Source;

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

   procedure Prepare_Context  (SF : SF_Id; Success : out Boolean) is separate;
   --  We need the possibility to use different bodies for non-GNSA and
   --  GNSA-based versions

   ------------------
   -- Pretty_Print --
   ------------------

   procedure Pretty_Print (Unit : Asis.Compilation_Unit; SF : SF_Id) is
      Program_Unit  : constant Asis.Element      := Unit_Declaration (Unit);

      Contex_Clause : constant Asis.Element_List :=
         Context_Clause_Elements (Unit, True);

      Comp_Pragmas : constant Asis.Element_List :=
        Compilation_Pragmas (Unit);

      First_Pragma_After : List_Index := Comp_Pragmas'Last + 1;

      Full_Span : constant Asis.Text.Span := Compilation_Span (Program_Unit);
      Unit_Span : constant Asis.Text.Span := Element_Span (Program_Unit);

      Source_Control    : Traverse_Control       := Continue;
      Source_State      : Source_Traversal_State := Initial_State;

      Success : Boolean := False;

      --  The following declarations are needed to process the parent unit name
      --  of a subunit. The problem with this construct is that in ASIS we
      --  do not have any means to represent this parent unit name as ASIS
      --  Element, so we have to simulate the corresponding traversing.

      type Program_Text_Access is access Program_Text;

      procedure Free is new
        Ada.Unchecked_Deallocation (Program_Text, Program_Text_Access);

      Parent_Name : Program_Text_Access;
      --  Represents image of the parent unit name.

      Next_Name_Start, Next_Name_End : Natural := 1;
      --  Pointers to the next component of the parent name.

      procedure Set_Next_Name_Component;
      --  Sets Next_Name_Start and Next_Name_End. If Next_Name_Start is already
      --  outside Parent_Name, does nothing.

      procedure Set_Next_Name_Component is
      begin

         if Next_Name_Start < Parent_Name'Last then
            Next_Name_End := Next_Name_Start;

            while Next_Name_End < Parent_Name'Last and then
                  Parent_Name (Next_Name_End + 1) /= '.'
            loop
               Next_Name_End := Next_Name_End + 1;
            end loop;

         end if;

      end Set_Next_Name_Component;

   begin
      GNATPP.State.Initialize;

      --  Feeding the line table

      Lines_Table.Set_Last (Full_Span.Last_Line);

      Lines_Table.Table (1 .. Full_Span.Last_Line) :=
         Lines_Table.Table_Type
           (Lines (Element    => Program_Unit,
                   First_Line => Full_Span.First_Line,
                   Last_Line  => Full_Span.Last_Line));

      GNATPP.Common.The_Unit      := Program_Unit; --  ??? why do we need this
      --  To keep the reference to this Element in the global variable

      GNATPP.Common.The_Last_Line := Full_Span.Last_Line;

      --  We separate the following parts of the original source:
      --
      --  1. Lines before the first context clause (if any). These lines may
      --     be either empty lines of comment lines
      --
      --  2. Context clause (starting from the first context item or pragma
      --     and down to the library item or subunit, including all the
      --     comments in between
      --
      --  3. Library item (or subunit) itself (Unit_Declaration in ASIS
      --     terms)
      --
      --  4. Lines after the end of the end of the Library item (or subunit),
      --     they may be empty lines, comment lines or they may contain
      --     prarmas

      --  Step #1: Lines before the first context clause

      Before_CU := True;

      GNATPP.State.Current_Line := 0;

      Get_Next_Ada_Lexem (Keep_Empty_Lines       => True,
                          Called_After_Ada_Token => False);

      --  Step #2: Context clause

      Traversal_Stack.Push ((Nil_Element, Nil_Span, Nil_Layout_Info));

      Before_CU         := False;
      In_Context_Clause := True;

      Compute_Alignment_In_Context_Clause (Contex_Clause);

      for J in Contex_Clause'Range loop

         if Flat_Element_Kind (Contex_Clause (J)) in Flat_Pragma_Kinds then
            Set_No_Paragraph;
         else

            if not In_Paragraph then
               Set_New_Paragraph;
            end if;

         end if;

         Traverse_Source (Contex_Clause (J), Source_Control, Source_State);
      end loop;

      --  Step #3: Library item (or subunit) itself

      In_Context_Clause := False;
      In_Unit           := True;

      if Unit_Kind (Unit) in A_Subunit then
         --  We have to print out 'separate (Parent_Unit_Name)'

         --  ???!!!

         --  The solution provided below is very simple and in can NOT
         --  reproduce comments inside 'separate (Parent_Unit_Name)'!!!

         PP_New_Line; --  ???
         PP_Keyword (KW_Separate);
         Get_Next_Ada_Lexem;
         PP_Continue_Line;
         PP_Delimiter (Left_Parenthesis_Dlm);
         Get_Next_Ada_Lexem;

         Parent_Name :=
           new Program_Text'(Unit_Full_Name
             (Corresponding_Subunit_Parent_Body (Unit)));

         Set_Next_Name_Component;

         while Next_Name_Start > 0 loop

            if Next_Name_End - Next_Name_Start + 1 > Available_In_Output then
               --  We check the space needed for the next name component
               --  and '.' or ')'
               PP_New_Continuation_Line;
            end if;

            PP_Word
              (Capitalize_Image
                 (Parent_Name (Next_Name_Start .. Next_Name_End),
                  PP_Name_Casing));

            Get_Next_Ada_Lexem;

            if Next_Name_End = Parent_Name'Last then
               --  The parent name is over!
               PP_Delimiter (Right_Parenthesis_Dlm);
               exit;
            else
               PP_Delimiter (Dot_Dlm);
               Next_Name_Start := Next_Name_End + 2;
               Set_Next_Name_Component;
               Get_Next_Ada_Lexem;
            end if;

         end loop;

         Free (Parent_Name);

         Get_Next_Ada_Lexem;
      end if;

      Traverse_Source (Program_Unit, Source_Control, Source_State);

      --  Step # 4: Lines after the end of the end of the Library item
      --  (or subunit),

      In_Unit     := False;
      Behind_Unit := True;

      --  Not sure that we need anything specific here... ???
      null;

      for J in Comp_Pragmas'Range loop

         if Unit_Span.Last_Line <=
            Element_Span (Comp_Pragmas (J)).First_Line
         then
            First_Pragma_After := J;
            exit;
         end if;

      end loop;

      for J in First_Pragma_After .. Comp_Pragmas'Last loop

         if Is_Equal (Enclosing_Compilation_Unit (Comp_Pragmas (J)), Unit) then
            --  We may have configuration pragmas in the list
            Traverse_Source (Comp_Pragmas (J), Source_Control, Source_State);
         end if;

      end loop;

      Behind_Unit := False;

      if Output_Mode /= Pipe and then
         Ada.Wide_Text_IO.Is_Open (Result_Out_File)
      then
         Ada.Wide_Text_IO.Close (Result_Out_File);

         if Out_File_Format /= Default then
            Correct_EOL;
         end if;
      end if;

      Set_Source_Status (SF, Processed);

      if Output_Mode in Replace .. Replace_No_Backup then

         if Hostparm.OpenVMS then
            Copy_File
              (Name     => Res_File_Name.all,
               Pathname => Source_Name (SF),
               Success  => Success,
               Mode     => Overwrite,
               Preserve => None);

         else
            Copy_File
              (Name     => Res_File_Name.all,
               Pathname => Source_Name (SF),
               Success  => Success,
               Mode     => Overwrite);
         end if;

         if not Success then
            Put (Standard_Error, "gnatpp: can not write the reformatted ");
            Put (Standard_Error, "source into ");
            Put (Standard_Error, Source_Name (SF));
            New_Line (Standard_Error);

            Set_Source_Status (SF, Error_Detected);
         end if;
      end if;

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

         Report_Unhandled_ASIS_Exception (Ex);

         if Output_Mode /= Pipe and then
            Ada.Wide_Text_IO.Is_Open (Result_Out_File)
         then
            Ada.Wide_Text_IO.Close (Result_Out_File);
         end if;

         Set_Source_Status (SF, Error_Detected);

      when Ex : others =>
         Report_Unhandled_Exception (Ex);

         if Output_Mode /= Pipe and then
            Ada.Wide_Text_IO.Is_Open (Result_Out_File)
         then
            Ada.Wide_Text_IO.Close (Result_Out_File);
         end if;

         Set_Source_Status (SF, Error_Detected);

   end Pretty_Print;

   -------------------------
   -- Process_Main_Source --
   -------------------------

   procedure Process_Main_Source (SF : SF_Id) is
      The_CU  : Asis.Compilation_Unit;
      Success : Boolean;
   begin

      Output_Source (SF);

      Prepare_Context (SF, Success);

      if not Success then
         Set_Source_Status (SF, Not_A_Legal_Source);

         Put_Line
           (Standard_Error, "gnatpp: " & Source_Name (SF) &
            " is not a legal Ada source");

         return;

      end if;

      Set_Output (SF, Success);

      if not Success then
         Set_Source_Status (SF, Out_File_Problem);
      else
         The_CU := Main_Unit_In_Current_Tree (The_Context);
         Set_Current_SF (SF);
         Pretty_Print (The_CU, SF);
      end if;

      declare
         All_CUs : constant Compilation_Unit_List :=
           Asis.Compilation_Units.Compilation_Units (The_Context);
         Next_SF : SF_Id;
      begin

         for J in All_CUs'Range loop

            Next_SF :=
              File_Find
               (Normalize_Pathname
                 (To_String (Text_Name (All_CUs (J))),
                  Resolve_Links  => False,
                  Case_Sensitive => False));

            if Present (Next_SF) and then
               Source_Status (Next_SF) = Waiting
            then
               Output_Source (Next_SF);
               Set_Output (Next_SF, Success);

               if not Success then
                  Set_Source_Status (Next_SF, Out_File_Problem);
               else
                  Set_Current_SF (Next_SF);
                  Pretty_Print (All_CUs (J), Next_SF);
               end if;

            end if;

         end loop;

      exception
         when Ex : others =>
            Put_Line
              (Standard_Error,
               "gnatpp: unknown bug detected when processing " &
                Source_Name (Next_SF));

            Put_Line
              (Standard_Error, "Please submit bug report to report@gnat.com");

            Report_Unhandled_Exception (Ex);

            raise Fatal_Error;

      end;

      Source_Clean_Up (SF);

   exception

      when Program_Error =>
         Source_Clean_Up (SF);
         raise;

      when Fatal_Error =>
         Source_Clean_Up (SF);
         raise;

      when Ex : others =>
         Put_Line
           (Standard_Error, "gnatpp: unknown bug detected when processing " &
            Source_Name (SF));

         Put_Line
           (Standard_Error, "Please submit bug report to report@gnat.com");

         Report_Unhandled_Exception (Ex);
         Source_Clean_Up (SF);

         raise Fatal_Error;

   end Process_Main_Source;

   ---------------------
   -- Process_Sources --
   ---------------------

   procedure Process_Sources (Only_Bodies : Boolean := False) is
      Next_SF : SF_Id;
   begin
      Reset_Source_Iterator;

      Next_SF := Next_Non_Processed_Source (Only_Bodies);

      while Present (Next_SF) loop
         Process_Main_Source (Next_SF);
         Next_SF := Next_Non_Processed_Source (Only_Bodies);
      end loop;

   end Process_Sources;

end GNATPP.Processing;