------------------------------------------------------------------------------
--                                                                          --
--                          GNATCHECK COMPONENTS                            --
--                                                                          --
--                ASIS_UL.SOURCE_TABLE.GNATCHECK_PROCESSING                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2004-2010, AdaCore                     --
--                                                                          --
-- GNATCHECK  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.  GNATCHECK  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.                                       --
--                                                                          --
-- GNATCHECK is maintained by AdaCore (http://www.adacore.com).             --
--                                                                          --
------------------------------------------------------------------------------

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

with GNAT.OS_Lib;                use GNAT.OS_Lib;

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

with ASIS_UL.Common;             use ASIS_UL.Common;
with Gnatcheck.Source_Checks;
with ASIS_UL.Debug;              use ASIS_UL.Debug;
with ASIS_UL.Global_State;
with ASIS_UL.Global_State.CG;
with ASIS_UL.Options;            use ASIS_UL.Options;
with ASIS_UL.Output;             use ASIS_UL.Output;
with ASIS_UL.Source_Table;
with ASIS_UL.Strings;            use ASIS_UL.Strings;
with ASIS_UL.Utilities;          use ASIS_UL.Utilities;

with Gnatcheck.Compiler;         use Gnatcheck.Compiler;
with Gnatcheck.Diagnoses;
with Gnatcheck.Exemption;
with Gnatcheck.Options;
with Gnatcheck.Rules;            use Gnatcheck.Rules;
with Gnatcheck.Rules.Traversing; use Gnatcheck.Rules.Traversing;
with Gnatcheck.Traversal_Stack;

package body ASIS_UL.Source_Table.Gnatcheck_Processing is

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

   procedure Process_Sources_From_Table (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_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 ASIS Compilation Unit corresponding to this source
   --  is processed. Then this routine tries to locate in the set of ASIS
   --  Compilation Units representing by this tree units corresponding to some
   --  other sources stored in the source table, and to process all these
   --  units. When the processing is complete, the tree file and the
   --  corresponding ALI file are deleted from the temporary directory.

   procedure Traverse_Source
     (CU : Asis.Compilation_Unit;
      SF : SF_Id);
   --  Implements the general ASIS Compilation Unit traversal algorythm:
   --  traverses the ASIS Compilation Unit CU contained in the source file SF,
   --  checks all the active rules, collects the information needed to create
   --  global structure. Sets SF status to Processed.

   procedure Debug_Output_Source (SF : SF_Id; Arg_Source : Boolean);
   --  In debug mode, outputs into Stderrthe short name of SF and either
   --  "(argument)" or "(needed)" string depending on the value of Arg_Source.
   --  The output is three positions indented.

   function Can_Be_Processed_From_Guest_Tree
     (CU   : Asis.Compilation_Unit)
      return Boolean;
   --  Checks if the argument unit can be processed on the base of a tree where
   --  this unit is not the main unit.
   --  ??? Now we unconditionally returns False. Impoving the productivity by
   --  means of reducung compilations requires more systematic design. The main
   --  problem here are expanded generic bodies - they can be processed from
   --  the tree created for the given unit in most of the cases.

   --------------------------------------
   -- Can_Be_Processed_From_Guest_Tree --
   --------------------------------------

   function Can_Be_Processed_From_Guest_Tree
     (CU   : Asis.Compilation_Unit)
      return Boolean
   is
      Result : Boolean := False;
   begin

      case Unit_Kind (CU) is
         when A_Generic_Unit_Instance =>
            --  We can get an expanded body only from the tree created for a
            --  library-level instantiation itself
            Result := False;
         when  A_Generic_Package |
               A_Package         =>

            if Is_Body_Required (CU) then
               --  If we have a generic instantiated in the spec, the expanded
               --  body for it will be in the unit body.
               Result := False;
            end if;

         when A_Package_Body =>
            --  If the body contains generic instantiations, they do not have
            --  expanded bodies in the "guest" tree
            Result := False;
         when others =>
            null;
      end case;

      return Result;
   end Can_Be_Processed_From_Guest_Tree;

   -------------------------
   -- Debug_Output_Source --
   -------------------------

   procedure Debug_Output_Source (SF : SF_Id; Arg_Source : Boolean) is
   begin

      if ASIS_UL.Options.Debug_Mode then
         Info_No_EOL ("   " & Short_Source_Name (SF));

         if Arg_Source then
            Info (" (argument)");
         else
            Info (" (needed)");
         end if;

      end if;

   end Debug_Output_Source;

   ----------------------
   -- Define_Exit_Code --
   ----------------------

   procedure Define_Exit_Code is
   begin

      if Gnatcheck.Diagnoses.Detected_Non_Exempted_Violations > 0 then
         Exit_Code := E_Violation;
      elsif Tool_Failures = 0 then
         Exit_Code := E_Success;
      else
         Exit_Code := E_Non_Trusted;
      end if;

   end Define_Exit_Code;

   --------------------
   -- Exit_Gnatcheck --
   --------------------

   procedure Exit_Gnatcheck (Exit_Code : Exit_Code_Type) is
   begin

      case Exit_Code is
         when E_Success     => OS_Exit (0);
         when E_Violation   => OS_Exit (1);
         when E_Fatal       => OS_Exit (2);
         when E_Non_Trusted => OS_Exit (2);
         when No_Check      => OS_Exit (3);
      end case;

   end Exit_Gnatcheck;

   --------------
   -- Finalize --
   --------------

   procedure Finalize is
   begin

      if not ASIS_UL.Options.Nothing_To_Do then

         if ASIS_UL.Options.Buld_Call_Graph then

            --  When creating a global data structure, we may have added new
            --  files (as needed files) in the sources table, and nodes in
            --  the global structure may refer to these added source as
            --  their enclosing sources. So we have to add the corresponding
            --  nodes to the diagnosis mapping table.

            for J in Last_Argument_Source + 1 .. Last_Source loop
               Gnatcheck.Diagnoses.Add_Line_To_Mapping_Table;
            end loop;

            if not ASIS_UL.Global_State.CG.Traverse_Renamings_Done then
               ASIS_UL.Global_State.CG.Traverse_Renamings;
            end if;

            if Do_Transitive_Closure then

               if ASIS_UL.Options.Debug_Mode then
                  Info ("Call graph closure ... ");
               end if;

               ASIS_UL.Global_State.CG.Transitive_Closure;
            end if;

            if ASIS_UL.Options.Debug_Mode then
               Info ("...Done");
            end if;

         end if;

         Gnatcheck.Rules.Traversing.Check_Global_Rules;

         if ASIS_UL.Options.Debug_Mode then
            ASIS_UL.Global_State.Print_Global_Structure;
   --           Gnatcheck.Diagnoses.Diag_Structure_Debug_Image;
         end if;

         if ASIS_UL.Options.Debug_Mode then
            Info ("Generate report ... ");
         end if;

         Gnatcheck.Diagnoses.Generate_Report;
         ASIS_UL.Output.Close_Report_File;

         if ASIS_UL.Options.Debug_Mode then
            Info ("...Done");
         end if;

         if Tool_Failures > 0 or else Debug_Mode then
            Info ("Total gnatcheck failures :" & Tool_Failures'Img);
         end if;

      end if;

      --  ??? to be (re)moved when categories are fully implemented
      if ASIS_UL.Options.Debug_Mode then
--         Print_Category_Hierarchy;
--         Pretty_Print_Category_Hierarchy;
         Gnatcheck.Diagnoses.Diag_Structure_Debug_Image;
         ASIS_UL.Source_Table.Source_Table_Debug_Image;
      end if;

   end Finalize;

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

   procedure Initialize is
   begin
      Gnatcheck.Diagnoses.Create_Mapping_Table;
      Gnatcheck.Exemption.Init_Compiler_Check_Exemptions_Storage;

      if ASIS_UL.Options.Buld_Call_Graph then
         ASIS_UL.Global_State.Initialize;
      end if;

      if Check_Restrictions then
         Create_Restriction_Pragmas_File;
      end if;

      Gnatcheck.Traversal_Stack.Initialize;

   end Initialize;

   --------------------
   -- Process_Source --
   --------------------

   procedure Process_Source (SF : SF_Id) is
      Success : Boolean;
      pragma Warnings (Off, Success);
      use type Asis.Errors.Error_Kinds;
   begin

      Output_Source (SF);

      --  We always send compiler output to temporary file to be able to
      --  store compiler error messages and to include them in final gnatcheck
      --  report
      Create_Temp_File (Compiler_Out_FD, Compiler_Out_File_Name);
      Close (Compiler_Out_FD);
      Delete_File (Compiler_Out_File_Name, Success);

      Create_Tree
        (SF,
         Success,
         Compiler_Out      => Compiler_Out_File_Name,
         All_Warnings_Off  => Suppess_Compiler_Check);

      if not Success then

         if Analyze_Compiler_Output then
            Close (Compiler_Out_FD);

            Analyze_Error_Messages
              (Compiler_Out_File_Name,
               Wrong_Option => Success);

            if Success then
               --  This means that wrong (style) parameters have been specified
               --  as compiler-related rule parameter, so the same error will
               --  be detected when compiling another source, so:
               raise Fatal_Error;
            end if;
         end if;

         Gnatcheck.Diagnoses.Store_Error_Messages (Compiler_Out_File_Name, SF);

         return;
      end if;

      Asis.Ada_Environments.Associate
       (The_Context => The_Context,
        Name        => "",
        Parameters  => "-C1 "
                      & To_Wide_String (Suffixless_Name (SF) & ".adt"));

      begin
         Asis.Ada_Environments.Open (The_Context);
         Success := True;

         if Debug_Flag_T then
            Print_Tree_Sources;
         end if;
      exception
         when Asis.Exceptions.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
               Error ("can not process redefinition of System in " &
                       Source_Name (SF));

               Set_Source_Status (SF, Not_A_Legal_Source);
               Success := False;
            else
               raise;
            end if;

      end;

      if Success then

         The_CU := Main_Unit_In_Current_Tree (The_Context);

         if Unit_Origin (The_CU) /= An_Application_Unit
           and then
            not Process_RTL_Units
         then
            Error ("cannot process RTL unit " & Source_Name (SF) &
                   " Use '-a' option for processing RTL components");
            Set_Source_Status (SF, Processed);
         else
            Set_Current_SF (SF);
            Traverse_Source (The_CU, SF);

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

               Next_SF : SF_Id;
            begin

               for J in All_CUs'Range loop

                  if Unit_Origin (All_CUs (J)) = An_Application_Unit
                   or else
                     not Process_RTL_Units
                  then

                     Next_SF :=
                       File_Find (Normalize_Pathname
                         (To_String (Text_Name (All_CUs (J)))));
                     Set_Current_SF (Next_SF);

                     if Is_Argument_Source (Next_SF)
                      and then
                        Source_Status (Next_SF) = Waiting
                     then
                        if Unit_Origin (All_CUs (J)) /= An_Application_Unit
                          and then
                           not Process_RTL_Units
                        then
                           Error ("cannot process RTL unit "         &
                                  Source_Name (Next_SF)              &
                                  " Use '-a' option for processing " &
                                  "RTL components");
                           Set_Source_Status (Next_SF, Processed);

                        elsif Can_Be_Processed_From_Guest_Tree
                                 (All_CUs (J))
                        then
                           The_CU := All_CUs (J);
                           Debug_Output_Source (Next_SF, Arg_Source => True);
                           Traverse_Source (All_CUs (J), Next_SF);
                        end if;

                     end if;

                  end if;

               end loop;

            exception
               when Ex : others =>
                  Error
                    ("unknown bug detected when processing " &
                      Source_Name (Next_SF));
                  Error_No_Tool_Name
                    ("Please submit bug report to report@adacore.com");
                  Report_Unhandled_Exception (Ex);
                  Source_Clean_Up (Next_SF);
                  raise Fatal_Error;

            end;

         end if;
      end if;

      if Analyze_Compiler_Output then
         Analyze_Compiler_Warnings (Compiler_Out_File_Name, SF);
         Close (Compiler_Out_FD);
      end if;

      if Is_Regular_File (Compiler_Out_File_Name) then
         Delete_File (Compiler_Out_File_Name, Success);
      end if;

      Source_Clean_Up (SF);

   exception

      when Fatal_Error =>
         raise;

      when Ex : others =>

         Error ("unknown bug detected when processing " & Source_Name (SF));
         Error_No_Tool_Name
           ("Please submit bug report to report@adacore.com");
         Report_Unhandled_Exception (Ex);

         Source_Clean_Up (SF);
         raise Fatal_Error;

   end Process_Source;

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

   procedure Process_Sources is
   begin

      if not Nothing_To_Do then

         Asis.Implementation.Initialize ("-k -asis05 -ws");

         Process_Sources_From_Table (Only_Bodies => True);
         Process_Sources_From_Table;

         Asis.Implementation.Finalize;
      end if;
   end Process_Sources;

   --------------------------------
   -- Process_Sources_From_Table --
   --------------------------------

   procedure Process_Sources_From_Table (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_Source (Next_SF);
         Next_SF := Next_Non_Processed_Source (Only_Bodies);
      end loop;

   end Process_Sources_From_Table;

   ---------------------
   -- Traverse_Source --
   ---------------------

   procedure Traverse_Source
     (CU : Asis.Compilation_Unit;
      SF : SF_Id)
   is
      Program_Unit  : constant Asis.Element      := Unit_Declaration (CU);
      Contex_Clause : constant Asis.Element_List :=
         Context_Clause_Elements (CU, True);

      Comp_Pragmas : constant Asis.Element_List :=
        Compilation_Pragmas (CU);
      First_Pragma_After : List_Index              := Comp_Pragmas'Last + 1;
      Unit_Span          : constant Asis.Text.Span :=
        Element_Span (Program_Unit);
      --  We also may have to check pragmas after the unit, that's why we need
      --  these objects.

      Check_Control : Traverse_Control     := Continue;
      Check_State   : Rule_Traversal_State :=
        (Initial_State, False, SF, 0, Nil_String_Loc, 0, 0, 0);
   begin

      if Gnatcheck.Options.Active_Rule_Present then

         Gnatcheck.Exemption.Init_Compiler_Check_Exemptions (SF);

         if Gnatcheck.Options.Analyse_Source_Text then
            Gnatcheck.Source_Checks.Init_Source_Text_Checks (Program_Unit);
         end if;

         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 Contex_Clause'Range loop
            Check_Rules (Contex_Clause (J), Check_Control, Check_State);
         end loop;

         Check_Rules (Program_Unit, Check_Control, Check_State);

         for J in First_Pragma_After .. Comp_Pragmas'Last loop

            if Is_Equal (Enclosing_Compilation_Unit (Comp_Pragmas (J)),
                         CU)
            then
               --  We may have configuration pragmas in the list
               Check_Rules (Comp_Pragmas (J), Check_Control, Check_State);
            end if;

         end loop;

         if Gnatcheck.Options.Analyse_Source_Text then
            Gnatcheck.Source_Checks.Check_Text_Rules_For_Remaining_Lines
              (Unit  => Program_Unit,
               State => Check_State);
         end if;

         Gnatcheck.Exemption.Check_Unclosed_Rule_Exemptions (SF, Program_Unit);
      end if;

      Set_Source_Status (SF, Processed);
   end Traverse_Source;

end ASIS_UL.Source_Table.Gnatcheck_Processing;