------------------------------------------------------------------------------
--                                                                          --
--                          GNATCHECK COMPONENTS                            --
--                                                                          --
--                ASIS_UL.SOURCE_TABLE.GNATCHECK_PROCESSING                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2004-2007, 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 ASIS_UL.Options;            use ASIS_UL.Options;
with ASIS_UL.Output;             use ASIS_UL.Output;
with ASIS_UL.Strings;            use ASIS_UL.Strings;

with Gnatcheck.Compiler;         use Gnatcheck.Compiler;
with Gnatcheck.Diagnoses;
with Gnatcheck.Global_State;
with Gnatcheck.Global_State.CG;
with Gnatcheck.Options;          use Gnatcheck.Options;
with Gnatcheck.Output;           use Gnatcheck.Output;
with Gnatcheck.Rules;            use Gnatcheck.Rules;
with Gnatcheck.Rules.Rule_Table; use Gnatcheck.Rules.Rule_Table;
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 ASIS_Processing (CU : Asis.Compilation_Unit; SF : SF_Id);
   --  Traverses the ASIS Compilation Unit CU contained in the source file SF,
   --  checks all the local rules, collecnts the information needed to create
   --  the global structure. Sets SF status to Processed.

   procedure Collect_Global_Info (CU : Asis.Compilation_Unit; SF : SF_Id);
   --  Traverses a unit and collects all the information needed to create a
   --  global structure. Sets SF to Processed

   procedure Traverse_Source
     (CU               : Asis.Compilation_Unit;
      SF               : SF_Id;
      Traverse_Routine : Access_To_Traverse_Routine);
   --  Implements the general ASIS Compilation Unit traversal algorythm used by
   --  ASIS_Processing and Collect_Global_Info

   procedure Collect_Global_Information;
   --  Processes all the sources that have not been processed yet (basically it
   --  should be sources added as needed sources during the main rule checking
   --  process and collects the information related to the global state of the
   --  program.

   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.

   ---------------------
   -- ASIS_Processing --
   ----------------------

   procedure ASIS_Processing (CU : Asis.Compilation_Unit;  SF : SF_Id) is
   begin
      Traverse_Source (CU, SF, Check_Rules'Access);
   end ASIS_Processing;

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

   -------------------------
   -- Collect_Global_Info --
   -------------------------

   procedure Collect_Global_Info (CU : Asis.Compilation_Unit; SF : SF_Id) is
   begin
      Traverse_Source (CU, SF, Extract_Global_Information'Access);
   end Collect_Global_Info;

   --------------------------------
   -- Collect_Global_Information --
   --------------------------------

   procedure Collect_Global_Information is
      Success : Boolean;
      SF      : SF_Id;
   begin
      --  The implementation is a simplified clone of
      --  Process_Sources

      if ASIS_UL.Options.Debug_Mode
       or else
         ASIS_UL.Options.Verbose_Mode
      then
         Info ("Processing needed sources...");
      end if;

      Reset_Source_Iterator;
      SF := Next_Non_Processed_Source (Include_Needed_Sources => True);

      while Present (SF) loop

         Total_Sources := Natural (Last_Source);
         Sources_Left  :=
           Total_Sources - Already_Processed (Include_Needed_Sources => True);

         Create_Tree
           (SF, Success, Compiler_Out => Compiler_Out_File_Name_String);

         if not Success then
            return;
         end if;

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

         declare
            use type Asis.Errors.Error_Kinds;
         begin
            Asis.Ada_Environments.Open (The_Context);
            Success := True;
         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

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

               Next_SF : SF_Id;
            begin

               Output_Source (SF);

               for J in All_CUs'Range loop

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

                  if Present (Next_SF)
                    and then
                     Source_Status (Next_SF) = Waiting
                    and then
                     (Unit_Origin (All_CUs (J)) = An_Application_Unit
                     or else
                      Process_RTL_Units)
                    and then
                     (Can_Be_Processed_From_Guest_Tree (All_CUs (J))
                     or else
                      Is_Main_Unit_In_Tree (All_CUs (J)))
                  then
                     Debug_Output_Source (Next_SF, Arg_Source => False);
                     The_CU := All_CUs (J);
                     --  Output_Source (Next_SF);
                     Collect_Global_Info (All_CUs (J), Next_SF);
                  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@gnat.com");
                  Report_Unhandled_Exception (Ex);
                  Source_Clean_Up (Next_SF);
                  raise Fatal_Error;

            end;

         end if;

         Source_Clean_Up (SF);

         SF := Next_Non_Processed_Source (Include_Needed_Sources => True);
      end loop;

   exception

      when Program_Error =>
         Error ("installation problem - check gnatcheck and GNAT versions");
         raise Fatal_Error;

      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@gnat.com");
         Report_Unhandled_Exception (Ex);
         Source_Clean_Up (SF);
         raise Fatal_Error;

   end Collect_Global_Information;

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

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

   procedure Finalize is
   begin

      if not ASIS_UL.Options.Nothing_To_Do then

         if Gnatcheck.Global_State.Buld_Call_Graph then

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

            Gnatcheck.Global_State.CG.Transitive_Closure;

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

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

      end if;

   end Finalize;

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

   procedure Initialize is
   begin
      Gnatcheck.Diagnoses.Create_Mapping_Table;

      Analyze_Compiler_Output :=
        Use_gnaty_Option or else Use_gnatw_Option or else Check_Restrictions;

      if Gnatcheck.Global_State.Buld_Call_Graph then
            Gnatcheck.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;
      use type Asis.Errors.Error_Kinds; --  for EC12-013
   begin

      Output_Source (SF);

      if Analyze_Compiler_Output then
         Create_Temp_File (Compiler_Out_FD, Compiler_Out_File_Name);
         Close (Compiler_Out_FD);
         Delete_File (Compiler_Out_File_Name, Success);
      end if;

      Create_Tree
        (SF, Success, Compiler_Out => Compiler_Out_File_Name_String);

      if not Success then

         if Analyze_Compiler_Output then
            Close (Compiler_Out_FD);
            Delete_File (Compiler_Out_File_Name, Success);
         end if;

         return;
      end if;

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

      declare
         use type Asis.Errors.Error_Kinds;
      begin
         Asis.Ada_Environments.Open (The_Context);
         Success := True;
      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
            ASIS_Processing (The_CU, SF);

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

               CUs_Processed  : array (All_CUs'Range) of Boolean :=
                 (others => False);
               --  Indicates if the given CU has been processed

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

                     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);
                           ASIS_Processing (All_CUs (J), Next_SF);
                           CUs_Processed (J) := True;
                        end if;

                     end if;

                  end if;

               end loop;

               --  And now - complete the global structure by processing the
               --  units that have been added as needed units when processing
               --  argument units.

               if Gnatcheck.Global_State.Buld_Call_Graph then

                  for J in All_CUs'Range loop

                     if not CUs_Processed (J) then
                        Next_SF :=
                          File_Find (Normalize_Pathname
                            (To_String (Text_Name (All_CUs (J)))));

                        if not (Unit_Origin (All_CUs (J)) /=
                                  An_Application_Unit
                              and then
                                not Process_RTL_Units)
                          and then
                           Is_Needed_Source (Next_SF)
                          and then
                           Can_Be_Processed_From_Guest_Tree (All_CUs (J))
                        then
                           Debug_Output_Source (Next_SF, Arg_Source => False);
                           Collect_Global_Info (All_CUs (J), Next_SF);
                        end if;

                     end if;

                  end loop;

               end if;

            exception
               when Ex : others =>
                  Error
                    ("unknown bug detected when processing " &
                      Source_Name (Next_SF));
                  Error_No_Tool_Name
                    ("Please submit bug report to report@gnat.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);
         Close (Compiler_Out_FD);
         Delete_File (Compiler_Out_File_Name, Success);
      end if;

      Source_Clean_Up (SF);

   exception

      when Program_Error =>
         Error ("installation problem - check gnatcheck and GNAT versions");
         raise Fatal_Error;

      when Fatal_Error =>
         raise;

      when Ex : others =>

         if Asis.Implementation.Status = Asis.Errors.Use_Error
           and then
            Asis.Implementation.Diagnosis =
            "Cannot process Ada sources compiled with -gnat05"
         then
            --  EC12-013: This path should be removed when ASIS 2005 is
            --  implemented
            Error ("Ada 2005 not supported yet, exiting");
         else
            Error ("unknown bug detected when processing " & Source_Name (SF));
            Error_No_Tool_Name ("Please submit bug report to report@gnat.com");
            Report_Unhandled_Exception (Ex);
         end if;

         Source_Clean_Up (SF);
         raise Fatal_Error;

   end Process_Source;

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

   procedure Process_Sources is
   begin
      if Generate_Rules_Help then
         Rules_Help;
      end if;

      if Last_Source = No_SF_Id then
         --  Nothing to do!
         if not Generate_Rules_Help  then
            Brief_Help;
         end if;

         return;
      end if;

      if ASIS_UL.Options.ASIS_2005_Mode then
         Asis.Implementation.Initialize ("-asis05 -ws");
      else
         Asis.Implementation.Initialize ("-ws");
      end if;

      Process_Sources_From_Table (Only_Bodies => True);
      Process_Sources_From_Table;

      if Gnatcheck.Global_State.Buld_Call_Graph then

         Collect_Global_Information;
      end if;

      Asis.Implementation.Finalize;
   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;
      Traverse_Routine : Access_To_Traverse_Routine)
   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

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

      Traverse_Routine (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
            Traverse_Routine (Comp_Pragmas (J), Check_Control, Check_State);
         end if;

      end loop;

      Set_Source_Status (SF, Processed);
   end Traverse_Source;

end ASIS_UL.Source_Table.Gnatcheck_Processing;
