------------------------------------------------------------------------------
--                                                                          --
--                          GNATCHECK COMPONENTS                            --
--                                                                          --
--                  G N A T C H E C K . D I A G N O S E S                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2005-2011, 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.Calendar;               use Ada.Calendar;
with Ada.Characters.Handling;    use Ada.Characters.Handling;
with Ada.Command_Line;
with Ada.Containers.Ordered_Sets;
with Ada.Exceptions;
with Ada.Strings;                use Ada.Strings;
with Ada.Strings.Fixed;          use Ada.Strings.Fixed;
with Ada.Text_IO;                use Ada.Text_IO;

with Gnatvsn;                    use Gnatvsn;

with Asis.Elements;              use Asis.Elements;
with Asis.Expressions;           use Asis.Expressions;
with Asis.Text;                  use Asis.Text;

with ASIS_UL.Common;             use ASIS_UL.Common;
with ASIS_UL.Compiler_Options;
with ASIS_UL.Environment;        use ASIS_UL.Environment;
with ASIS_UL.Misc;               use ASIS_UL.Misc;
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.Options;          use Gnatcheck.Options;
with Gnatcheck.Rules;            use Gnatcheck.Rules;
with Gnatcheck.Rules.Rule_Table; use Gnatcheck.Rules.Rule_Table;

package body Gnatcheck.Diagnoses is

   -----------------------
   -- Diagnoses storage --
   -----------------------

   type Diag_Message is record
      Text               : String_Access;
      Justification      : String_Access;
      Diagnosis_Kind     : Diagnosis_Kinds;
      Rule               : Rule_Id;
      SF                 : SF_Id;
      Num                : Positive;
      --  Is needed to order properly messages corresponding to the same SLOC.
   end record;

   function Diag_Is_Less_Then (L, R : Diag_Message) return Boolean;
   --  If L or R is null, raises Constraint_Error. Otherwise compares SLOC
   --  parts of L and R (file names are converted to lower case (is it correct?
   --  what about case sensitive file systems???). If SLOC parts do not contain
   --  instantiation chains, then they are compared. If both SLOCs contain
   --  instantiation chains, first the SLOCs of (the last) instantiations (that
   --  is, the rightmost SLOCs in the chains) are compared, and if they are
   --  equal, the SLOCs in the templates (the leftmost SLOCs in the chains) are
   --  compared. If one SLOC contains an instantiation chain, but another one
   --  does not, then at the first step the SLOC of the last instantiation is
   --  compared with another SLOC, and in case if they are equal, the SLOC
   --  without instantiation chain is considered as being less then the SLOC
   --  with the chain. All SLOCs are compared lexicographically.
   --
   --  If comparing SLOCs based on the rules given
   --  above results in the fact that these SLOCs are equal, Num parts are
   --  compared.

   function Diag_Is_Equal (L, R : Diag_Message) return Boolean;
   --  If L or R is null, raises Constraint_Error. Otherwise returns
   --  "="(L.Text.all, R.Text.all), where "=" is predefined equality for
   --  String.

   package Error_Messages_Storage is new Ada.Containers.Ordered_Sets
     (Element_Type => Diag_Message,
      "<"          => Diag_Is_Less_Then,
      "="          => Diag_Is_Equal);

   All_Error_Messages : Error_Messages_Storage.Set;

   Unused_Position : Error_Messages_Storage.Cursor;
   Unused_Inserted : Boolean;

   -------------------------------------------
   --  Local routines for diagnoses storage --
   -------------------------------------------

   procedure Compute_Statisctics;
   --  Computes the number of violations and diagnoses of different kinds.
   --  Results are stored in the corresponding counters in the package spec.
   --  Also computes file statistics and stores it in the following counters.
   --  (Should we move all the counters in the body?)
   Checked_Sources                  : Natural := 0;
   Unverified_Sources               : Natural := 0;
   Fully_Compliant_Sources          : Natural := 0;
   Sources_With_Violations          : Natural := 0;
   Sources_With_Exempted_Violations : Natural := 0;

   procedure Diag_Srorage_Debug_Image;
   --  Prints out the debug image of the debug storage.

   function Next_Message_Num return Positive;
   --  Returns next value for the Num field of diagnostic message

   -------------------------------------------
   --  Local routines for report generation --
   -------------------------------------------

   Source_List_File_Name : constant String := "gnatcheck-source-list.out";
   --  Name of the file with all the argument file names created by
   --  gnatcheck if a used-provided file cannot be used for this.

   Rule_List_File_Name : constant String := "gnatcheck-rule-list.out";
   --  Name of the file with all the active rules with their actual parameters
   --  created by gnatcheck if a used-provided coding standard file cannot be
   --  used for this.

   function All_Sources_In_One_File return Boolean;
   --  Checks if all the argument sources are listed in a single user-provided
   --  file. In case if gnatcheck is called from the GNAT driver analyses
   --  the original call sequence for the GNAT driver.

   procedure Copy_User_Info;
   --  Copies into the report file the text from user-provided file.

   procedure Print_Active_Rules_File;
   --  Prints the reference to the (actual argument or artificially created)
   --  file that contains the list of all the rules that are active for the
   --  given gnatcheck run

   procedure Print_Argument_Files_Summary;
   --  Prints the total numbers of: all the argument files, non-compilable
   --  files, files with no violations, files with violations, files with
   --  exempted violations only.

   Diagnoses_To_Print : array (Rule_Violation .. Compiler_Error) of Boolean :=
     (others => False);
   --  Specifies which diagnoses should be printed out by the following
   --  procedure

   Print_Exempted_Violations : Boolean;
   --  Flag specifying if exempted or non-exempted violations should be
   --  printed. Has its effect only if Diagnoses_To_Print (Rule_Violation) is
   --  True.

   procedure Print_Diagnoses;
   --  Iterates through all the diagnoses and prints into the report file those
   --  of them, for which Diagnoses_To_Print is True (and the value of
   --  Print_Exempted_Violations either corresponds to the diagnosis or is not
   --  applicable for the diagnosis kind).

   procedure Print_Failure_Info;
   pragma Unreferenced (Print_Failure_Info);
   --  Prints info about non-fatal failures detected during gnatcheck run.

   procedure Print_File_List_File;
   --  Prints the reference to the (actual argument or artificially created)
   --  file that contains the list of all the files passed to gnatcheck

   procedure Print_Gnatcheck_Command_Line;
   --  Prints the gnatcheck command line. In case if gnatcheck has been
   --  called from the GNAT driver, prints the call to the GNAT driver, but not
   --  the gnatcheck call generated by the GNAT driver.

   procedure Print_Out_Diagnoses;
   --  Duplicates diagnoses about non-exempted rule violations, exemption
   --  warnings and compiler error messages into Stderr. Up to Max_Diagnoses
   --  diagnoses are reported. If Max_Diagnoses equal to 0, all the diagnoses
   --  of these kinds are reported.

   procedure Print_Report_Header;
   --  Generates the report header, including the date, tool version and
   --  tool command liner invocation sequence.

   procedure Print_Runtime;
   --  Prints the runtime version used for gnatcheck call. It is either the
   --  parameter of --RTS option used for (actual) gnatcheck call or the
   --  "<default>" string if --RTS parameter is not specified.

   procedure Print_Violation_Summary;
   --  Prints the total numbers of: non-exempted)violations, exempted
   --  violations, exemption warnings and compiler errors.

   function Select_Line (Diag : String_Access) return Positive;
   --   Assuming that Diag is a diagnosis, gets the line number from it. The
   --  result is undefined if Diag does not have a syntax of the diagnosis.
   --  At the moment this function does not work properly if Diag contains
   --  a SLOC pointing into expanded instantiation.

   ----------------------------------------------------------------------
   --  Data structures and local routines for rule exemption mechanism --
   ----------------------------------------------------------------------

   type Exemption_Kinds is
     (Not_An_Exemption,
      Exempt_On,
      Exempt_Off);

   function Get_Exemption_Kind (Image : Wide_String) return Exemption_Kinds;
   --  Returns Exemption_Kinds value represented by Image. Returns
   --  Not_An_Exemption if Image does not represent a valid exemption kind.

   type Exemption_Info is record
      Line_Start : Natural;
      Col_Start  : Natural;
      --  Location of exemption pragma that turns exemption ON

      Line_End : Natural;
      Col_End  : Natural;
      --  End of the exemption section

      Justification : String_Access;

      Detected : Natural;
      --  Number of the diagnoses generated for exempted rule
   end record;

   type Exemption_Sections_Array is array (Rule_Id range <>) of Exemption_Info;
   type Exemption_Sections_Array_Access is access Exemption_Sections_Array;
   Exemption_Sections : Exemption_Sections_Array_Access;
   --  Storage for currently processed exemption sections. Should have a
   --  separate entry for each rule. (We cannot allocate it statically because
   --  of elaboration problems - we do not know how many rules we have unlit
   --  all of them are registered).

   procedure Postponed_Exemptions_Debug_Image;
   --  Prints out the debug image of the exemption section storage for the
   --  rules that require processing of exemptions after processing all the
   --  sources (compiler checks, global rules, what else?)

   function Is_Exempted (Rule : Rule_Id) return Boolean;
   --  Checks if Rule is in exempted state. Assumes Present (Rule).

   procedure Process_Postponed_Exemptions;
   --  ??? To be fully specified and implemented.
   --  The idea is to iterate through the stored diagnoses and to try to apply
   --  postponed exemption to global rules and diagnoses generated for expanded
   --  generics, and for compiler checks

   procedure Turn_Off_Exemption
     (Rule         : Rule_Id;
      Closing_Span : Asis.Text.Span;
      SF           : SF_Id);
   --  Cleans up the stored exemption section for the argument Rule, for some
   --  rules (global rules, rules checked of expanded instantiations, compiler
   --  checks) the exemption section is stored in some rule-specific data
   --  structure before being cleaning up.

   --------------------------------------
   --  Exemptions for postponed checks --
   --------------------------------------

   type Postponed_Rule_Exemption_Info;
   type  Postponed_Rule_Exemption_Info_Access is access
     Postponed_Rule_Exemption_Info;

   type Postponed_Rule_Exemption_Info is record
      Exemption_Section      : Exemption_Info;
      SF                     : SF_Id;
      Next_Exemption_Section : Postponed_Rule_Exemption_Info_Access;
   end record;

   type Postponed_Check_Exemption_Sections_Array is array (SF_Id range <>) of
     Postponed_Rule_Exemption_Info_Access;

   type Postponed_Check_Exemption_Sections_Array_Access is access
     Postponed_Check_Exemption_Sections_Array;

   type Postponed_Exemption_Sections_Array is array (Rule_Id range <>) of
     Postponed_Check_Exemption_Sections_Array_Access;

   type Postponed_Exemption_Sections_Array_Access is access
     Postponed_Exemption_Sections_Array;

   Postponed_Exemption_Sections : Postponed_Exemption_Sections_Array_Access;
--   array (Compiler_Checks) of  --  ????
--     Postponed_Check_Exemption_Sections_Array_Access;
   --  For each argument source, stores all the compiler check exemption
   --  sections found in this source. These sections are stored as they are
   --  processed - that is, in alphabetical order. Sections for different kinds
   --  of compiler checks are stored separately.

   type Current_Postponed_Exemption_Sections_Array is array
     (Rule_Id range <>) of Postponed_Rule_Exemption_Info_Access;

   type Current_Postponed_Exemption_Sections_Array_Access is access
     Current_Postponed_Exemption_Sections_Array;

   Current_Postponed_Exemption_Sections :
     Current_Postponed_Exemption_Sections_Array_Access;
--   array (Compiler_Checks) of  --  ????
--     Postponed_Rule_Exemption_Info_Access;
   --  Point to the last exemption section for the corresponding postponed
   --  check for currently processed file when storing exemption sections, or
   --  to the last traversed section when mapping diagnoses on exemption
   --  sections. Equals to null if no such section has been encountered yet.
   --  When storing exemption sections, are reset by ???, are modified by
   --  Turn_Off_Exemption procedure. When mapping diagnoses onto exemption
   --  sections, ???

   function Needs_Postponed_Exemption_Processing
     (Rule : Rule_Id)
      return Boolean;
   --  Checks if the exemption processing for the argument rule should be
   --  postponed till all the sources are processed. For the moment returns
   --  True for compiler checks, global rules and rules that are checked on
   --  expanded generics

   procedure Add_Exempted_Violation (For_Check : Rule_Id);
   --  Adds 1 to the detection counter for the currently accessed section for
   --  the argument check

   function Get_Justification (For_Check : Rule_Id) return String_Access;
   --  Gets justification from the currently accessed section for the argument
   --  check

   function Get_Original_SF (Diag : Diag_Message) return SF_Id;
   --  In case if the diagnosis is formulated for expanded instantiation,
   --  returns the ID if the file containing the template code (or No_SF_Id if
   --  this file is not a gnatcheck argument), otherwise returns the source
   --  file ID stored in the diagnosis

   procedure Map_On_Postponed_Check_Exemption      --  ???
     (In_File     :     SF_Id;
      For_Check   :     Rule_Id;
      For_Line    :     Positive;
      Is_Exempted : out Boolean);
   --  This procedure first sets the appropriate current postponed rule check
   --  section for the argument check and then checks if For_Line parameter
   --  gets into the corresponding exemption section and sets Is_Exempted
   --  accordingly. Setting the appropriate rule check sections means
   --  the following. If source file in the current section is not equal to
   --  In_File, the first section for In_File is set as current exemption
   --  section. Then sections for the given file are traversed until the
   --  section that either contains For_Line is found, or the section that
   --  starts after For_Line is reached, or all the section chain is exceeded
   --  (in this case the last section is set as current). If there is no
   --  exemption section In_File, then Is_Exempted is set to False

   --  Parsed_File : SF_Id := No_SF_Id;
   --  The file that is currently parsed and that contains Annotate pragmas
   --  being processed.

   ----------------------------
   -- Add_Exempted_Violation --
   ----------------------------

   procedure Add_Exempted_Violation (For_Check : Rule_Id) is
   begin
      Current_Postponed_Exemption_Sections (For_Check).Exemption_Section.
        Detected :=
          Current_Postponed_Exemption_Sections (For_Check).Exemption_Section.
            Detected + 1;
   end Add_Exempted_Violation;

   -----------------------------
   -- All_Sources_In_One_File --
   -----------------------------

   function All_Sources_In_One_File return Boolean is
      Result : Boolean;
   begin
      Result := not Individual_Files_Specified
              and then
                Arg_Source_File_Name /= "";

      if Result
        and then
         Getenv ("GNAT_DRIVER_COMMAND_LINE") /= null
      then
         --  Analyze GNAT driver call
         declare
            GNAT_Driver_Call : constant String :=
              Getenv ("GNAT_DRIVER_COMMAND_LINE").all;

            Word_Start : Natural := GNAT_Driver_Call'First;
            Word_End   : Natural := GNAT_Driver_Call'First;

            First_Idx :           Natural := GNAT_Driver_Call'First;
            Last_Idx  : constant Natural := GNAT_Driver_Call'Last;

            Num_Of_Arg_Files : Natural := 0;

            procedure Set_Word;
            --  Select Word_Start and Word_End to point to the first word in
            --  GNAT_Driver_Call (First_Idx .. Last_Idx), and then set
            --  First_Idx to Word_End + 1. If there is no word any more in
            --  GNAT_Driver_Call (First_Idx .. Last_Idx), set Word_Start to
            --  Last_Idx + 1

            procedure Set_Word is
            begin
               Word_Start := Last_Idx + 1;

               for J in First_Idx .. Last_Idx loop
                  if GNAT_Driver_Call (J) /= ' ' then
                     Word_Start := J;
                     exit;
                  end if;
               end loop;

               if Word_Start <= Last_Idx then
                  Word_End := Last_Idx;

                  for J in Word_Start .. Last_Idx loop
                     if GNAT_Driver_Call (J) = ' ' then
                        Word_Start := J - 1;
                        exit;
                     end if;
                  end loop;

                  First_Idx := Word_End + 1;
               end if;

            end Set_Word;

         begin
            --  Just in case:
            if GNAT_Driver_Call = "" then
               goto Result_Detected;
            end if;

            --  First, case when -U option is given:
            if Index (GNAT_Driver_Call, "-U") /= 0 then
               Result := False;
               goto Result_Detected;
            end if;

            --  Here we have to parse the string.
            --  Skip the call sequence up to the space after 'check' - there is
            --  nothing interesting in it

            First_Idx :=
              Index (Ada.Characters.Handling.To_Lower (GNAT_Driver_Call),
                    "check");
            First_Idx := First_Idx + 5;

            Set_Word;

            while Word_Start <= Last_Idx loop
               if GNAT_Driver_Call (Word_Start) = '-' then
                  case GNAT_Driver_Call (Word_Start + 1) is
                     when 'a' |
                          'd' |
                          'h' |
                          'm' |
                          'q' |
                          't' |
                          'v' |
                          's' |
                          'l' |
                          '-' =>
                        --  Just skip the option, either gnatcheck's or
                        --  GNAT driver's
                        null;
                     when 'c' | -- 'cargs'
                          'r' => -- 'rules'
                        --  No information about argument sources in the rest
                        --  of the call sequence
                        exit;
                     when 'P' |
                          'o' =>
                        --  Project file: we can have either '-P prj' or -Pprj
                        --  Specification of the output file: we may have
                        --  either '-o bla' or -o=foo
                        if Word_Start + 1 = Word_End then
                           Set_Word;
                        else
                           null;
                        end if;

                     when 'f' =>
                        --  Specification of the argument file list: we may
                        --  have either -files=foo or '-files bar'

                        Num_Of_Arg_Files := Num_Of_Arg_Files + 1;

                        if Num_Of_Arg_Files > 1 then
                           Result := False;
                           goto Result_Detected;
                        end if;

                        if Word_Start + 5 = Word_End then
                           Set_Word;
                        end if;

                     when others =>
                        Error ("bug in command line analysis");
                        Error ("report a problem to report@adacore.com");
                        raise Fatal_Error;
                  end case;
               else
                  --  Definitely an explicitly specified file name, so
                  Result := False;
                  goto Result_Detected;
               end if;

               Set_Word;
            end loop;

            if Result and then Num_Of_Arg_Files = 0 then
               --  Call to the GNAT driver with no argument files specified,
               --  all the project files should be processed
               Result := False;
            end if;
         end;
      end if;

      <<Result_Detected>> return Result;
   end All_Sources_In_One_File;

   ------------------------------------
   -- Check_Unclosed_Rule_Exemptions --
   ------------------------------------

   procedure Check_Unclosed_Rule_Exemptions
     (SF   : SF_Id;
      Unit : Asis.Element)
   is
      Comp_Span : constant Span := Compilation_Span (Unit);
   begin

      for Rule in Exemption_Sections'Range loop
         if Is_Exempted (Rule) then
            Store_Diagnosis
              (Text               =>
                 Short_Source_Name (SF)                       & ':'    &
                 Image (Exemption_Sections (Rule).Line_Start) & ':'    &
                 Image (Exemption_Sections (Rule).Col_Start)  & ": "   &
                 "No matching 'exempt_OFF' annotation "       &
                 "for rule " & Rule_Name (Rule),
               Diagnosis_Kind     => Exemption_Warning,
               SF                 => SF);

            Turn_Off_Exemption
              (Rule         => Rule,
               Closing_Span => Comp_Span,
               SF           => SF);
         end if;
      end loop;

   end Check_Unclosed_Rule_Exemptions;

   -------------------------
   -- Compute_Statisctics --
   -------------------------

   procedure Compute_Statisctics is
      type Violations_Detected is record
         Exempted_Violations_Detected     : Boolean := False;
         Non_Exempted_Violations_Detected : Boolean := False;
      end record;

      File_Counter : array (First_SF_Id .. Last_Argument_Source) of
        Violations_Detected := (others => (False, False));

      procedure Count_Diagnoses (Position : Error_Messages_Storage.Cursor);

      procedure Count_Diagnoses (Position : Error_Messages_Storage.Cursor) is
         SF : constant SF_Id := Error_Messages_Storage.Element (Position).SF;
      begin
         case Error_Messages_Storage.Element (Position).Diagnosis_Kind is
            when Not_A_Diagnosis =>
               pragma Assert (False);
               null;
            when Rule_Violation =>
               if Error_Messages_Storage.Element (Position).Justification =
                  null
               then
                  Detected_Non_Exempted_Violations :=
                    Detected_Non_Exempted_Violations + 1;
                  File_Counter (SF).Non_Exempted_Violations_Detected := True;
               else
                  Detected_Exempted_Violations :=
                    Detected_Exempted_Violations + 1;
                  File_Counter (SF).Exempted_Violations_Detected := True;
               end if;
            when Exemption_Warning =>
               Detected_Exemption_Warning := Detected_Exemption_Warning + 1;
            when Compiler_Error =>
               Detected_Compiler_Error := Detected_Compiler_Error + 1;
         end case;
      end Count_Diagnoses;
   begin
      Error_Messages_Storage.Iterate
        (Container => All_Error_Messages,
         Process   => Count_Diagnoses'Access);

      for SF in First_SF_Id .. Last_Argument_Source loop
         if Source_Status (SF) in Not_A_Legal_Source .. Error_Detected then
            Unverified_Sources := Unverified_Sources + 1;
         else
            Checked_Sources := Checked_Sources + 1;

            if File_Counter (SF).Non_Exempted_Violations_Detected then
               Sources_With_Violations := Sources_With_Violations + 1;
            elsif File_Counter (SF).Exempted_Violations_Detected then
               Sources_With_Exempted_Violations :=
                 Sources_With_Exempted_Violations + 1;
            elsif Source_Status (SF) = Processed then
               Fully_Compliant_Sources := Fully_Compliant_Sources + 1;
            end if;
         end if;

      end loop;

   end Compute_Statisctics;

   --------------------
   -- Copy_User_Info --
   --------------------

   procedure Copy_User_Info is
      Max_Line_Len : constant Positive := 1024;
      Line_Buf     :          String (1 .. Max_Line_Len);
      Line_Len     :          Natural;
      User_File    :          Ada.Text_IO.File_Type;
   begin
      --  Very simple-minded implementation...

      Open (File => User_File,
            Mode => In_File,
            Name => User_Info_File_Full_Path.all);

      Get_Line (File => User_File,
                Item => Line_Buf,
                Last => Line_Len);

      while not End_Of_File (User_File) loop
         Report (Line_Buf (1 .. Line_Len));

         Get_Line (File => User_File,
                   Item => Line_Buf,
                   Last => Line_Len);
      end loop;

      Close (User_File);
   exception
      when E : others =>

         Report_EOL;
         Report ("cannot successfully copy information " &
                 "from " & User_Info_File.all);

         if Is_Open (User_File) then
            Close (User_File);
         end if;

         Error ("cannot copy information from " & User_Info_File.all &
                " into report file");

         Error_No_Tool_Name (Ada.Exceptions.Exception_Information (E));
   end Copy_User_Info;

   -------------------
   -- Diag_Is_Equal --
   -------------------

   function Diag_Is_Equal (L, R : Diag_Message) return Boolean is
   begin
      return L.Text.all = R.Text.all;
   end Diag_Is_Equal;

   -----------------------
   -- Diag_Is_Less_Then --
   -----------------------

   function Diag_Is_Less_Then (L, R : Diag_Message) return Boolean is
      L_SLOC_Start : Natural;
      R_SLOC_Start : Natural;

      L_SLOC_End   : Natural := Index (L.Text.all, ": ") - 1;
      R_SLOC_End   : Natural := Index (R.Text.all, ": ") - 1;

      L_Has_Chain : Boolean;
      R_Has_Chain : Boolean;

      Result : Boolean;
   begin
      if Diag_Is_Equal (L, R) then
         return False;
      end if;

      L_Has_Chain := L.Text (L_SLOC_End) = ']';
      R_Has_Chain := R.Text (R_SLOC_End) = ']';

      if L_Has_Chain then
         while L.Text (L_SLOC_End) = ']' loop
            L_SLOC_End := L_SLOC_End - 1;
         end loop;

         L_SLOC_Start := L_SLOC_End;

         while L.Text (L_SLOC_Start) /= '[' loop
            L_SLOC_Start := L_SLOC_Start - 1;
         end loop;

         L_SLOC_Start := L_SLOC_Start + 1;
      else
         L_SLOC_Start := L.Text'First;
      end if;

      if R_Has_Chain then
         while R.Text (R_SLOC_End) = ']' loop
            R_SLOC_End := R_SLOC_End - 1;
         end loop;

         R_SLOC_Start := R_SLOC_End;

         while R.Text (R_SLOC_Start) /= '[' loop
            R_SLOC_Start := R_SLOC_Start - 1;
         end loop;

         R_SLOC_Start := R_SLOC_Start + 1;
      else
         R_SLOC_Start := R.Text'First;
      end if;

      Result := SLOC_Less_Then (L.Text (L_SLOC_Start .. L_SLOC_End),
                                R.Text (R_SLOC_Start .. R_SLOC_End));

      if L.Text (L_SLOC_Start .. L_SLOC_End) /=
         R.Text (R_SLOC_Start .. R_SLOC_End)
      then
         return Result;
      else
         --  If we are here, SLOCs are the same
         if L_Has_Chain and then not R_Has_Chain then
            return False;
         elsif not L_Has_Chain and then R_Has_Chain then
            return True;
         end if;
      end if;

      --  If we are here then either both SLOC have chains or none of them has
      --  a chain. If we have chains, we have to compare SLOCs in templates:

      if L_Has_Chain then
         pragma Assert (R_Has_Chain);
         L_SLOC_Start := L.Text'First;
         R_SLOC_Start := R.Text'First;

         L_SLOC_End := Index (L.Text.all, "[") - 1;
         R_SLOC_End := Index (R.Text.all, "[") - 1;

         if L.Text (L_SLOC_Start .. L_SLOC_End) /=
            R.Text (R_SLOC_Start .. R_SLOC_End)
         then
            if L.Text (L_SLOC_Start .. L_SLOC_End) /=
               R.Text (R_SLOC_Start .. R_SLOC_End)
            then
               return SLOC_Less_Then (L.Text (L_SLOC_Start .. L_SLOC_End),
                                      R.Text (R_SLOC_Start .. R_SLOC_End));
            end if;
         end if;
      end if;

      --  And if we are here, we have equal SLOCs (both with instantiation
      --  chains or both - without chains), so

      return L.Num < R.Num;
   end Diag_Is_Less_Then;

   -----------------------------
   -- Exemption_Justification --
   -----------------------------

   function Exemption_Justification (Rule : Rule_Id) return String_Access is
   begin
      return Exemption_Sections (Rule).Justification;
   end Exemption_Justification;

   ------------------------------
   -- Diag_Srorage_Debug_Image --
   ------------------------------

   procedure Diag_Srorage_Debug_Image is
      procedure Debug_Image (Position : Error_Messages_Storage.Cursor);

      procedure Debug_Image (Position : Error_Messages_Storage.Cursor) is
         Tmp : constant Diag_Message :=
           Error_Messages_Storage.Element (Position);
      begin
         Info ("Text");
         Info (Tmp.Text.all);

         Info ("Justification");

         if Tmp.Justification = null then
            Info ("<no justification>");
         else
            Info (Tmp.Justification.all);
         end if;

         Info ("Diagnosis_Kind: " & Tmp.Diagnosis_Kind'Img);

         if Tmp.Diagnosis_Kind = Rule_Violation then
            Info ("Rule          :"  & Tmp.Rule'Img &
                  '(' & Rule_Name (Tmp.Rule) & ')');
         end if;

         Info ("SF            :" & Tmp.SF'Img);
         Info ("Num           :" & Tmp.Num'Img);
         Info ("");
      end Debug_Image;

   begin
      Info ("***Diagnoses storage debug image start");

      Error_Messages_Storage.Iterate
        (Container => All_Error_Messages,
         Process   => Debug_Image'Access);

      Info ("***Diagnoses storage debug image end");
   end Diag_Srorage_Debug_Image;

   -----------------------------------
   -- Generate_Qualification_Report --
   -----------------------------------

   procedure Generate_Qualification_Report is
   begin
      Process_Postponed_Exemptions;
      Compute_Statisctics;

      --  OVERVIEW
      if not Short_Report then

         Print_Report_Header;
         Print_Active_Rules_File;
         Print_File_List_File;
         Print_Argument_Files_Summary;
         Report_EOL;
         Print_Violation_Summary;
--         Print_Failure_Info;

         --  2. DETECTED EXEMPTED RULE VIOLATIONS
         Report_EOL;
         Report ("2. Exempted Coding Standard Violations");
         Report_EOL;
      end if;

      if Detected_Exempted_Violations > 0 then
         Diagnoses_To_Print := (Rule_Violation    => True,
                                Exemption_Warning => False,
                                Compiler_Error    => False);
         Print_Exempted_Violations := True;

         Print_Diagnoses;
      else
         Report ("no exempted violations detected", 1);
      end if;

      if not Short_Report then
         Report_EOL;
         Report ("3. Non-exempted Coding Standard Violations");
         Report_EOL;
      end if;

      if Detected_Non_Exempted_Violations > 0 then
         Diagnoses_To_Print := (Rule_Violation    => True,
                                Exemption_Warning => False,
                                Compiler_Error    => False);
         Print_Exempted_Violations := False;

         Print_Diagnoses;
      else
         Report ("no non-exempted violations detected", 1);
      end if;

      if not Short_Report then
         Report_EOL;
         Report ("4. Rule exemption problems");
         Report_EOL;
      end if;

      if Detected_Exemption_Warning > 0 then
         Diagnoses_To_Print := (Rule_Violation    => False,
                                Exemption_Warning => True,
                                Compiler_Error    => False);

         Print_Diagnoses;
      else
         Report ("no rule exemption problems detected", 1);
      end if;

      if not Short_Report then
         Report_EOL;
         Report ("5. Language violations");
         Report_EOL;
      end if;

      if Detected_Compiler_Error > 0 then
         Diagnoses_To_Print := (Rule_Violation    => False,
                                Exemption_Warning => False,
                                Compiler_Error    => True);

         Print_Diagnoses;
      else
         Report ("no language violations detected", 1);
      end if;

         --  User-defined part

      if not Short_Report then

         Report_EOL;

         if User_Info_File /= null then
            Report ("6. Additional Information");
            Report_EOL;
            Copy_User_Info;
            Report_EOL;

         end if;

      end if;

      --  Sending the diagnoses into Stderr.
      if not Quiet_Mode then
         Print_Out_Diagnoses;
      end if;

      if Debug_Diagnoses_Storage then
         Diag_Srorage_Debug_Image;
         Postponed_Exemptions_Debug_Image;
      end if;

   end Generate_Qualification_Report;

   ------------------------
   -- Get_Exemption_Kind --
   ------------------------

   function Get_Exemption_Kind (Image : Wide_String) return Exemption_Kinds is
      Result : Exemption_Kinds;
   begin

      if Image (Image'First) = '"' then
         Result :=
           Exemption_Kinds'Wide_Value
             (Image (Image'First + 1 .. Image'Last - 1));
      --  Old format of Annotate pragma. We have to cut out quotation marks
      else
         Result :=
           Exemption_Kinds'Wide_Value (Image);
      end if;

      return Result;
   exception
      when Constraint_Error =>
         return Not_An_Exemption;
   end Get_Exemption_Kind;

   -----------------------
   -- Get_Justification --
   -----------------------

   function Get_Justification (For_Check : Rule_Id) return String_Access is
   begin
      return Current_Postponed_Exemption_Sections (For_Check).
                Exemption_Section.Justification;
   end Get_Justification;

   ---------------------
   -- Get_Original_SF --
   ---------------------

   function Get_Original_SF (Diag : Diag_Message) return SF_Id is
      Result    : SF_Id := Diag.SF;
      Start_Idx : Natural;
      End_Idx   : Natural := Index (Diag.Text.all, "[");
   begin
      if End_Idx > 0 then
         End_Idx   := Index (Diag.Text.all, ":") - 1;
         Start_Idx := Diag.Text'First;
         Result :=
           File_Find (Diag.Text (Start_Idx .. End_Idx),
                      Use_Short_Name => True);
      end if;

      return Result;
   end Get_Original_SF;

   ---------------------
   -- Init_Exemptions --
   ---------------------

   procedure Init_Exemptions is
   begin
      Exemption_Sections :=
        new Exemption_Sections_Array (First_Compiler_Check .. All_Rules.Last);

      Exemption_Sections.all := (others =>
        (Line_Start    => 0,
         Col_Start     => 0,
         Line_End      => 0,
         Col_End       => 0,
         Justification => null,
         Detected      => 0));

      Postponed_Exemption_Sections :=
        new Postponed_Exemption_Sections_Array
          (First_Compiler_Check .. All_Rules.Last);

      Current_Postponed_Exemption_Sections :=
        new Current_Postponed_Exemption_Sections_Array
          (First_Compiler_Check .. All_Rules.Last);

      for Rule in Postponed_Exemption_Sections'Range loop

         if Needs_Postponed_Exemption_Processing (Rule) then
            Postponed_Exemption_Sections (Rule) :=
              new Postponed_Check_Exemption_Sections_Array
                (First_SF_Id .. Last_Argument_Source);
            Postponed_Exemption_Sections (Rule).all := (others => null);
         end if;

      end loop;

   end Init_Exemptions;

   -------------------------------------
   -- Init_Postponed_Check_Exemptions --
   -------------------------------------

   procedure Init_Postponed_Check_Exemptions is
   begin
      --  !!!??? FREE THE MEMORY!!!

      for Rule in Current_Postponed_Exemption_Sections'Range loop

         if Needs_Postponed_Exemption_Processing (Rule) then
            Current_Postponed_Exemption_Sections (Rule) := null;
         end if;

      end loop;
   end Init_Postponed_Check_Exemptions;

   -----------------
   -- Is_Exempted --
   -----------------

   function Is_Exempted (Rule : Rule_Id) return Boolean is
   begin
      return Exemption_Sections (Rule).Line_Start > 0;
   end Is_Exempted;

   -------------------------
   -- Is_Exemption_Pragma --
   -------------------------

   function Is_Exemption_Pragma (El : Asis.Element) return Boolean is
      Result : Boolean := False;
   begin

      if Pragma_Kind (El) = An_Implementation_Defined_Pragma
        and then
         To_Lower (To_String (Pragma_Name_Image (El))) = "annotate"
      then

         declare
            Pragma_Args : constant Asis.Element_List :=
              Pragma_Argument_Associations (El);
            --  Always non-empty for Annotate pragma!
            First_Par : Asis.Element;
         begin
            First_Par := Pragma_Args (Pragma_Args'First);
            First_Par := Actual_Parameter (First_Par);

            if To_Lower (To_String (Name_Image (First_Par))) = "gnatcheck" then
               Result := True;
            end if;
         end;

      end if;

      return Result;
   end Is_Exemption_Pragma;

   ---------------------------------------
   -- Map_On_Postponed_Check_Exemption --
   ---------------------------------------

   procedure Map_On_Postponed_Check_Exemption
     (In_File     :     SF_Id;
      For_Check   :     Rule_Id;
      For_Line    :     Positive;
      Is_Exempted : out Boolean)
   is
   begin
      Is_Exempted := False;

      if Postponed_Exemption_Sections (For_Check) (In_File) = null then
         return;
      end if;

      if Current_Postponed_Exemption_Sections (For_Check) = null
        or else
         Current_Postponed_Exemption_Sections (For_Check).SF /= In_File
      then
         Current_Postponed_Exemption_Sections (For_Check) :=
          Postponed_Exemption_Sections (For_Check) (In_File);
      end if;

      --  Traverse exemption section chain:
      while Current_Postponed_Exemption_Sections (For_Check) /= null loop
         if For_Line in
            Current_Postponed_Exemption_Sections (For_Check).Exemption_Section.
              Line_Start
                ..
            Current_Postponed_Exemption_Sections (For_Check).Exemption_Section.
              Line_End
         then
            Is_Exempted := True;
            exit;
         end if;

         if For_Line <
            Current_Postponed_Exemption_Sections (For_Check).Exemption_Section.
              Line_Start
         then
            exit;
         end if;

         Current_Postponed_Exemption_Sections (For_Check) :=
           Current_Postponed_Exemption_Sections (For_Check).
             Next_Exemption_Section;
      end loop;

   end Map_On_Postponed_Check_Exemption;

   ------------------------------------------
   -- Needs_Postponed_Exemption_Processing --
   ------------------------------------------

   function Needs_Postponed_Exemption_Processing
     (Rule : Rule_Id)
      return Boolean
   is
      Result : Boolean := Rule in Compiler_Checks;
   begin

      if not Result then
         Result :=
           Is_Global (Rule)
          or else
           Checked_On_Expanded_Code (All_Rules.Table (Rule).all);
      end if;

      return Result;
   end Needs_Postponed_Exemption_Processing;

   ----------------------
   -- Next_Message_Num --
   ----------------------

   Next_Message_Num_Value : Natural := 0;

   function Next_Message_Num return Positive is
   begin
      Next_Message_Num_Value := Next_Message_Num_Value + 1;
      return Next_Message_Num_Value;
   end Next_Message_Num;

   --------------------------------------
   -- Postponed_Exemptions_Debug_Image --
   --------------------------------------

   procedure Postponed_Exemptions_Debug_Image is
      procedure Sections_Debug_Image
        (S : Postponed_Rule_Exemption_Info_Access);

      procedure Sections_Debug_Image
        (S : Postponed_Rule_Exemption_Info_Access)
      is
         Tmp : Postponed_Rule_Exemption_Info_Access := S;
      begin
         if Tmp = null then
            Info ("*no exemption section");
         else
            while Tmp /= null loop
               Info ("Section " & Tmp.Exemption_Section.Line_Start'Img &
                     ':' & Tmp.Exemption_Section.Col_Start'Img & " - " &
                     Tmp.Exemption_Section.Line_End'Img &
                     ':' & Tmp.Exemption_Section.Col_End'Img);
               Info ("SF: " & Tmp.SF'Img);
               Info ("Detected: " & Tmp.Exemption_Section.Detected'Img);
               Info ("Justification: " &
                     Tmp.Exemption_Section.Justification.all);

               Tmp := Tmp.Next_Exemption_Section;
            end loop;
         end if;
      end Sections_Debug_Image;
   begin
      Info ("***Compiler check exemptions debug image start");

      for SF in First_SF_Id .. Last_Argument_Source loop
         Info ("***Exemption sections for " & Short_Source_Name (SF));

         for Rule in Postponed_Exemption_Sections'Range loop

            if Needs_Postponed_Exemption_Processing (Rule) then
               Info ("** " & Rule_Name (Rule));
               Sections_Debug_Image (Postponed_Exemption_Sections (Rule) (SF));
            end if;

         end loop;

      end loop;

      Info ("***Compiler check exemptions debug image end");
   end Postponed_Exemptions_Debug_Image;

   -----------------------------
   -- Print_Active_Rules_File --
   -----------------------------

   procedure Print_Active_Rules_File is
      Rule_List_File : Ada.Text_IO.File_Type;
   begin
      Report_No_EOL ("coding standard   : ");

      if not Individual_Rules_Set
        and then
         Rule_File_Name /= null
      then
         Report (Rule_File_Name.all);
      else
         --  Creating the list of active rules in Rule_List_File_Name

         if Is_Regular_File
           (Tool_Current_Dir & Directory_Separator & Rule_List_File_Name)
         then
            Open
              (Rule_List_File,
               Out_File,
               Tool_Current_Dir & Directory_Separator & Rule_List_File_Name);
         else
            Create
              (Rule_List_File,
               Out_File,
               Tool_Current_Dir & Directory_Separator & Rule_List_File_Name);
         end if;

         for Rule in All_Rules.First .. All_Rules.Last loop

            if All_Rules.Table (Rule).Diagnosis /= null
             and then
               Is_Enable (All_Rules.Table (Rule).all)
            then
               --  Note, that if a rule does not have its own diagnoses, this
               --  means that it is implemented by some other rules, so it
               --  should not go into the report

               Print_Rule_To_File (All_Rules.Table (Rule).all, Rule_List_File);
               New_Line (Rule_List_File);
            end if;
         end loop;

         New_Line (Rule_List_File);

         --  Compiler-made checks:

         if Use_gnaty_Option then
            New_Line (Rule_List_File);
            Put_Line (Rule_List_File, "-- Compiler style checks:");
            Put      (Rule_List_File, "+RStyle_Checks : ");
            Put_Line (Rule_List_File,
                      Get_Style_Option
                        (Get_Style_Option'First + 6 .. Get_Style_Option'Last));
         end if;

         if Use_gnatw_Option then
            New_Line (Rule_List_File);
            Put_Line (Rule_List_File, "--  Compiler warnings:");
            Put      (Rule_List_File, "+RWarnings : ");
            Put_Line (Rule_List_File,
                      Get_Specified_Warning_Option
                        (Get_Specified_Warning_Option'First + 6 ..
                         Get_Specified_Warning_Option'Last));
         end if;

         if Check_Restrictions then
            New_Line (Rule_List_File);
            Put_Line (Rule_List_File, "--  Compiler restrictions:");
            Print_Active_Restrictions_To_File (Rule_List_File);
         end if;

         Close (Rule_List_File);

         Report (Rule_List_File_Name);
      end if;

   end Print_Active_Rules_File;

   ----------------------------------
   -- Print_Argument_Files_Summary --
   ----------------------------------

   procedure Print_Argument_Files_Summary is
   begin

      Report ("1. Summary");
      Report_EOL;

      Report ("fully compliant sources               :" &
              Fully_Compliant_Sources'Img, 1);
      Report ("sources with exempted violations only :" &
              Sources_With_Exempted_Violations'Img, 1);
      Report ("sources with non-exempted violations  :" &
              Sources_With_Violations'Img, 1);
      Report ("unverified sources                    :" &
              Unverified_Sources'Img, 1);
      Report ("total sources                         :" &
              Last_Argument_Source'Img, 1);

      pragma Assert (Checked_Sources =
                       Fully_Compliant_Sources +
                       Sources_With_Violations +
                       Sources_With_Exempted_Violations);
      pragma Assert (Natural (Last_Argument_Source) =
                       Checked_Sources + Unverified_Sources);
   end Print_Argument_Files_Summary;

   ---------------------
   -- Print_Diagnoses --
   ---------------------

   procedure Print_Diagnoses is

      procedure Print_Specified_Diagnoses
        (Position : Error_Messages_Storage.Cursor);

      procedure Print_Specified_Diagnoses
        (Position : Error_Messages_Storage.Cursor)
      is
         Diag : constant Diag_Message :=
           Error_Messages_Storage.Element (Position);
      begin
         if Diagnoses_To_Print (Diag.Diagnosis_Kind) then

            if Diag.Diagnosis_Kind = Rule_Violation
              and then
                Print_Exempted_Violations =
                (Diag.Justification = null)
            then
               return;
            end if;

            Report (Diag.Text.all);

            if Diag.Justification /= null then
               Report ("(" & Diag.Justification.all & ")", 1);
            end if;
         end if;
      end Print_Specified_Diagnoses;

   begin
      Error_Messages_Storage.Iterate
        (Container => All_Error_Messages,
         Process   => Print_Specified_Diagnoses'Access);
   end Print_Diagnoses;

   ------------------------
   -- Print_Failure_Info --
   ------------------------

   procedure Print_Failure_Info is
   begin

      if Tool_Failures > 0 then
         Report ("Total gnatcheck failures:" & Tool_Failures'Img);
         Report_EOL;
      end if;

   end Print_Failure_Info;

   --------------------------
   -- Print_File_List_File --
   --------------------------

   procedure Print_File_List_File is
      Source_List_File : Ada.Text_IO.File_Type;
   begin
      Report_No_EOL ("list of sources   : ");

      if All_Sources_In_One_File then
         Report (Arg_Source_File_Name);
      else
         --  Creating the list of processed sources in Source_List_File_Name

         if Is_Regular_File
           (Tool_Current_Dir & Directory_Separator & Source_List_File_Name)
         then
            Open
              (Source_List_File,
               Out_File,
               Tool_Current_Dir & Directory_Separator & Source_List_File_Name);
         else
            Create
              (Source_List_File,
               Out_File,
               Tool_Current_Dir & Directory_Separator & Source_List_File_Name);
         end if;

         for SF in First_SF_Id .. Last_Argument_Source loop
            Put_Line (Source_List_File, Short_Source_Name (SF));
         end loop;

         Close (Source_List_File);

         Report (Source_List_File_Name);
      end if;

      Report_EOL;
   end Print_File_List_File;

   ----------------------------------
   -- Print_Gnatcheck_Command_Line --
   ----------------------------------

   procedure Print_Gnatcheck_Command_Line is
      GNAT_Driver_Call : constant String_Access :=
       Getenv ("GNAT_DRIVER_COMMAND_LINE");

   begin
      if GNAT_Driver_Call /= null
       and then
         GNAT_Driver_Call.all /= ""
      then
         Report (GNAT_Driver_Call.all);
      else
         Report_No_EOL (Ada.Command_Line.Command_Name);

         for Arg in 1 .. Ada.Command_Line.Argument_Count loop
            Report_No_EOL (" " & Ada.Command_Line.Argument (Arg));
         end loop;

         Report_EOL;
      end if;

   end Print_Gnatcheck_Command_Line;

   -------------------------
   -- Print_Out_Diagnoses --
   -------------------------

   procedure Print_Out_Diagnoses is
      Diagnoses_Reported : Natural := 0;
      Limit_Exceeded : Boolean := False;

      procedure Counted_Print_Diagnosis
        (Position : Error_Messages_Storage.Cursor);

      procedure Counted_Print_Diagnosis
        (Position : Error_Messages_Storage.Cursor)
      is
      begin
         if not Limit_Exceeded then
            if Diagnoses_Reported > Max_Diagnoses then
               Limit_Exceeded := True;
               Info ("Maximum diagnoses reached, "&
                     "see the report file for full details");
            else
               if Error_Messages_Storage.Element (Position).Justification =
                  null
               then
                  Diagnoses_Reported := Diagnoses_Reported + 1;
                  Info (Error_Messages_Storage.Element (Position).Text.all);
               end if;
            end if;
         end if;
      end Counted_Print_Diagnosis;

   begin
      Error_Messages_Storage.Iterate
        (Container => All_Error_Messages,
         Process   => Counted_Print_Diagnosis'Access);
   end Print_Out_Diagnoses;

   -------------------------
   -- Print_Report_Header --
   -------------------------

   procedure Print_Report_Header is
      Time_Of_Check   : constant Time := Clock;
      Month_Of_Check  : constant Month_Number := Month (Time_Of_Check);
      Day_Of_Check    : constant Day_Number   := Day (Time_Of_Check);
      Sec_Of_Check    : constant Day_Duration := Seconds (Time_Of_Check);

      Hour_Of_Chech   :          Integer range 0 .. 23;
      Minute_Of_Check :          Integer range 0 .. 59;
      Seconds_In_Hour : constant Integer := 60 * 60;

   begin
      Report ("GNATCheck report");
      Report_EOL;

      Report_No_EOL ("date              : ");
      Report_No_EOL (Trim (Year (Time_Of_Check)'Img, Left) & '-');

      if Month_Of_Check < 10 then
         Report_No_EOL ("0");
      end if;

      Report_No_EOL (Trim (Month_Of_Check'Img, Left) & '-');

      if Day_Of_Check < 10 then
         Report_No_EOL ("0");
      end if;

      Report_No_EOL (Trim (Day_Of_Check'Img, Left) & ' ');

      Hour_Of_Chech   := Integer (Sec_Of_Check) / Seconds_In_Hour;
      Minute_Of_Check := (Integer (Sec_Of_Check) rem Seconds_In_Hour) / 60;

      if Hour_Of_Chech < 10 then
         Report_No_EOL ("0");
      end if;

      Report_No_EOL (Trim (Hour_Of_Chech'Img, Left) & ':');

      if Minute_Of_Check < 10 then
         Report_No_EOL ("0");
      end if;

      Report        (Trim (Minute_Of_Check'Img, Left));

      Report_No_EOL ("gnatcheck version : ");
      Report_No_EOL (Tool_Name.all &  ' ');
      Report        (Gnat_Version_String);

      Report_No_EOL ("command line      : ");
      Print_Gnatcheck_Command_Line;

      Report_No_EOL ("runtime           : ");
      Print_Runtime;
   end Print_Report_Header;

   -------------------
   -- Print_Runtime --
   -------------------

   procedure Print_Runtime is
   begin
      if ASIS_UL.Compiler_Options.Custom_RTS /= null then
         Report (ASIS_UL.Compiler_Options.Custom_RTS.all);
      else
         Report ("<default>");
      end if;
   end Print_Runtime;

   -----------------------------
   -- Print_Violation_Summary --
   -----------------------------

   procedure Print_Violation_Summary is
   begin
      Report
        ("non-exempted violations               :" &
         Detected_Non_Exempted_Violations'Img, 1);

      Report
        ("rule exemption warnings               :" &
         Detected_Exemption_Warning'Img, 1);

      Report
        ("compilation errors                    :" &
        Detected_Compiler_Error'Img, 1);

      Report
        ("exempted violations                   :" &
         Detected_Exempted_Violations'Img, 1);
   end Print_Violation_Summary;

   ------------------------------
   -- Process_Exemption_Pragma --
   ------------------------------

   procedure Process_Exemption_Pragma (El : Asis.Element) is
      Pragma_Args : constant Asis.Element_List :=
        Pragma_Argument_Associations (El);

      First_Idx   : constant Natural := Pragma_Args'First;
      Next_Arg    :          Asis.Element;
      Tmp_Str     :          String_Access;
      Exem_Span   :          Asis.Text.Span := Nil_Span;
      SF          : constant SF_Id := File_Find (El);

      Rule           : Rule_Id;
      Exemption_Kind : Exemption_Kinds;
   begin
      --  We do not analyze exemption pragmas in instantiations - at the moment
      --  it is not clear how to define reasonable exemption policy for nested
      --  instantiations

      if Is_Part_Of_Instance (El) then
         return;
      end if;

      --  First, analyze the pragma format:
      --
      --  1. Check that we have at least three parameters

      if Pragma_Args'Length < 3 then
         Store_Diagnosis
           (Text           => Build_GNAT_Location (El) &
                              ": too few parameters for exemption, ignored",
            Diagnosis_Kind     => Exemption_Warning,
            SF                 => SF);

         return;
      end if;

      --  2. Second parameter should be either "Exempt_On" or "Exempt_Off"

      Next_Arg := Pragma_Args (First_Idx + 1);
      Next_Arg := Actual_Parameter (Next_Arg);

      if Expression_Kind (Next_Arg) = A_String_Literal then
         Exemption_Kind := Get_Exemption_Kind (Value_Image (Next_Arg));
      elsif Expression_Kind (Next_Arg) = An_Identifier then
         Exemption_Kind := Get_Exemption_Kind (Name_Image (Next_Arg));
      end if;

      if Exemption_Kind = Not_An_Exemption then
         Store_Diagnosis
           (Text               => Build_GNAT_Location (Next_Arg) &
                                  ": wrong exemption kind, ignored",
            Diagnosis_Kind     => Exemption_Warning,
            SF                 => SF);

         return;
      end if;

      --  3. Third parameter should be the name of some existing rule:

      Next_Arg := Pragma_Args (First_Idx + 2);
      Next_Arg := Actual_Parameter (Next_Arg);

      if Expression_Kind (Next_Arg) = A_String_Literal then
         Tmp_Str := new String'(To_String (Value_Image (Next_Arg)));
         Rule    := Get_Rule (Tmp_Str (Tmp_Str'First + 1 .. Tmp_Str'Last - 1));
         Free (Tmp_Str);
      else
         Rule := No_Rule;
      end if;

      if not Present (Rule) then
         Store_Diagnosis
           (Text               => Build_GNAT_Location (Next_Arg) &
                                  ": wrong rule name in exemption, ignored",
            Diagnosis_Kind     => Exemption_Warning,
            SF                 => SF);

         return;
      end if;

      --  4. Fourth parameter, if present, should be a string.

      if Pragma_Args'Length >= 4 then
         Next_Arg := Pragma_Args (First_Idx + 3);
         Next_Arg := Actual_Parameter (Next_Arg);

         if Expression_Kind (Next_Arg) = A_String_Literal then
            Tmp_Str := new String'(To_String (Value_Image (Next_Arg)));
         end if;

         if Tmp_Str = null then
            Store_Diagnosis
              (Text               => Build_GNAT_Location (Next_Arg) &
                                     ": exemption justification "   &
                                     "should be a string",
               Diagnosis_Kind     => Exemption_Warning,
               SF                 => SF);
         end if;

         --  5. Fourth parameter is ignored if exemption is turned OFF

         if Exemption_Kind = Exempt_Off then
            Store_Diagnosis
              (Text               => Build_GNAT_Location (Next_Arg) &
                                     ": turning exemption OFF "     &
                                     "does not need justification",
               Diagnosis_Kind     => Exemption_Warning,
               SF                 => SF);
         end if;

      end if;

      --  6. If exemption is turned ON, justification is expected

      if Exemption_Kind = Exempt_On
        and then
         Pragma_Args'Length = 3
      then
         Store_Diagnosis
           (Text           => Build_GNAT_Location (El) &
                              ": turning exemption ON expects justification",
            Diagnosis_Kind     => Exemption_Warning,
            SF                 => SF);
      end if;

      if Pragma_Args'Length >= 5 then
         Next_Arg := Pragma_Args (First_Idx + 4);

         Store_Diagnosis
           (Text               => Build_GNAT_Location (Next_Arg) &
                                  ": rule exemption may have "   &
                                  " at most four parameters",
            Diagnosis_Kind     => Exemption_Warning,
            SF                 => SF);
      end if;

      --  If Rule does not denote the enabled rule - nothing to do

      if not (Is_Enabled (Rule)
             or else
              (Rule = Warnings_Id
               and then
               Is_Enabled (Restrictions_Id)))
      then
         --  In case when a Restriction rule is enabled, we may want to use
         --  exemptions section for Warnings rule to suppress default warnings.
         --  We may get rid of this if and when we get a possibility to turn
         --  off all the warnings except related to restrictions only.
         return;
      end if;

      --  Now - processing of the exemption pragma. If we are here, we are
      --  sure, that:
      --  - Rule denotes and existing and enabled rule;
      --  - if we are in an expanded instance, this rule should be checked on
      --    the expanded code
      --
      --  Exemptions for global rules are not implemented yet!
      --  Exemptions for local rules that should be checked on expanded
      --  instantiations are not fully implemented!

      Exem_Span := Element_Span (El);

      case Exemption_Kind is
         when Exempt_On =>

            if Tmp_Str = null then
               Tmp_Str := new String'("""unjustified""");
            end if;

               if Is_Exempted (Rule) then
                  Store_Diagnosis
                    (Text => Build_GNAT_Location (El)       &
                             ": rule " & Rule_Name (Rule)   &
                             " is already exempted at line" &
                             Exemption_Sections (Rule).Line_Start'Img,
                     Diagnosis_Kind     => Exemption_Warning,
                     SF                 => SF);

                  return;
               end if;

               Exemption_Sections (Rule) :=
                 (Line_Start    => Exem_Span.First_Line,
                  Col_Start     => Exem_Span.First_Column,
                  Line_End      => 0,
                  Col_End       => 0,
                  Justification => new String'((Tmp_Str
                                     (Tmp_Str'First + 1 .. Tmp_Str'Last - 1))),
                  Detected      => 0);

            Free (Tmp_Str);

         when Exempt_Off =>

            if not Is_Exempted (Rule) then
               Store_Diagnosis
                 (Text           => Build_GNAT_Location (El)     &
                                    ": rule " & Rule_Name (Rule) &
                                    " is not in exempted state",
                  Diagnosis_Kind => Exemption_Warning,
                  SF             => SF);

               return;
            end if;

            Turn_Off_Exemption (Rule, Exem_Span, SF);

         when Not_An_Exemption =>
            pragma Assert (False);
            null;
      end case;

   end Process_Exemption_Pragma;

   ----------------------------------
   -- Process_Postponed_Exemptions --
   ----------------------------------

   procedure Process_Postponed_Exemptions is

      Next_Postponed_Section : Postponed_Rule_Exemption_Info_Access;

      procedure Map_Diagnosis (Position : Error_Messages_Storage.Cursor);
      --  Maps the diagnosis pointed by the argument onto stored information
      --  about exemption sections. If the diagnosis points to some place
      --  inside some exemption section, and the diagnosis is not exempted,
      --  then the diagnosis is exempted by adding the justification from the
      --  exemption section, and the corresponding exemption violation is
      --  counted for the given exemption section
      --
      --  At the moment this kind of diagnoses post-processing is implemented
      --  for compiler checks only.

      procedure Map_Diagnosis (Position : Error_Messages_Storage.Cursor) is
         Diag : Diag_Message := Error_Messages_Storage.Element (Position);
         Diag_Line   : Positive;
         SF          : SF_Id;
         Is_Exempted : Boolean;
      begin
         if Diag.Diagnosis_Kind = Rule_Violation
           and then
             Needs_Postponed_Exemption_Processing (Diag.Rule)
         then
            if Diag.Justification /= null then
               --  some diagnoses may be already exempted as a part of the
               --  regular processing
               return;
            end if;

            SF := Get_Original_SF (Diag);

            if not Present (SF) then
               --  This is the case when the diagnosis is generated for
               --  expanded generic, and the generic itself is not the
               --  gnatcheck argument
               return;
            end if;

            Diag_Line := Select_Line (Diag.Text);

            Map_On_Postponed_Check_Exemption
              (In_File     => SF,
               For_Check   => Diag.Rule,
               For_Line    => Diag_Line,
               Is_Exempted => Is_Exempted);

            if Is_Exempted then
               Add_Exempted_Violation (Diag.Rule);
               Diag.Justification := Get_Justification (Diag.Rule);

               Error_Messages_Storage.Replace_Element
                 (Container => All_Error_Messages,
                  Position  => Position,
                  New_Item  => Diag);
            end if;
         end if;
      end Map_Diagnosis;

   begin
      --  !!!??? Still does not work on rules checked on expanded generic!!!

      Error_Messages_Storage.Iterate
        (Container => All_Error_Messages,
         Process   => Map_Diagnosis'Access);

      --  Now, iterate through the stored exemption and generate exemption
      --  warnings for those of them for which no exempted diagnoses are found.

      --  Compiler checks exemptions:

      for Rule in First_Compiler_Check .. All_Rules.Last loop
         if Needs_Postponed_Exemption_Processing (Rule) then
            for SF in First_SF_Id .. Last_Argument_Source loop

               Next_Postponed_Section :=
                 Postponed_Exemption_Sections (Rule) (SF);

               while Next_Postponed_Section /= null loop

                  if Next_Postponed_Section.Exemption_Section.Detected = 0 then
                     Store_Diagnosis
                       (Text => Short_Source_Name (SF) & ':' &
                                Image
                                  (Next_Postponed_Section.Exemption_Section.
                                     Line_End)
                                & ':' &
                                Image
                                  (Next_Postponed_Section.Exemption_Section.
                                     Col_End) &
                                ": no detection for "                         &
                                Rule_Name (Rule)                              &
                                " rule in exemption section starting at line" &
                                Next_Postponed_Section.Exemption_Section.
                                  Line_Start'Img,

                        Diagnosis_Kind => Exemption_Warning,
                        SF             => SF);
                  end if;

                  Next_Postponed_Section :=
                    Next_Postponed_Section.Next_Exemption_Section;
               end loop;
            end loop;
         end if;

      end loop;

   end Process_Postponed_Exemptions;

   -----------------
   -- Select_Line --
   -----------------

   function Select_Line (Diag : String_Access) return Positive is
      Start_Idx : Natural;
      End_Idx   : Natural;
   begin
      Start_Idx := Index (Diag.all, ":") + 1;
      End_Idx   := Index (Diag (Start_Idx .. Diag'Last), ":") - 1;

      return Positive'Value (Diag (Start_Idx .. End_Idx));
   end Select_Line;

   ---------------------
   -- Store_Diagnosis --
   ---------------------

   procedure Store_Diagnosis
     (Text           : String;
      Diagnosis_Kind : Diagnosis_Kinds;
      SF             : SF_Id;
      Rule           : Rule_Id        := No_Rule;
      Justification  : String_Access  := null)
   is
   begin
      Error_Messages_Storage.Insert
        (Container => All_Error_Messages,
         New_Item  => (Text               => new String'(Text),
                       Justification      => Justification,
                       Diagnosis_Kind     => Diagnosis_Kind,
                       Rule               => Rule,
                       SF                 => SF,
                       Num                => Next_Message_Num),
         Position  => Unused_Position,
         Inserted  => Unused_Inserted);

      if Justification /= null then
         Exemption_Sections (Rule).Detected :=
            Exemption_Sections (Rule).Detected + 1;
      end if;

   end Store_Diagnosis;

   --------------------------
   -- Store_Error_Messages --
   --------------------------

   procedure Store_Error_Messages
     (Compiler_Out_Fname : String;
      SF                 : SF_Id)
   is
      Comp_Out_File : Ada.Text_IO.File_Type;
      Line_Buffer   : String (1 .. 16 * 1024);
      Line_Len      : Natural := 0;

      Is_Error_Message    : Boolean;
      Error_Message_Found : Boolean := False;
   begin
      pragma Assert (Source_Status (SF) = Not_A_Legal_Source);

      if not Is_Regular_File (Compiler_Out_Fname) then
         Error ("no compiler message file found for " & Source_Name (SF));
         return;
      end if;

      Open
        (File => Comp_Out_File,
         Mode => In_File,
         Name => Compiler_Out_Fname);

      while not End_Of_File (Comp_Out_File) loop
         Get_Line
           (File => Comp_Out_File,
            Item => Line_Buffer,
            Last => Line_Len);

         Is_Error_Message :=
           Index
             (Source  => Line_Buffer (1 .. Line_Len),
              Pattern => "(style)") = 0;

         if Is_Error_Message then
            Is_Error_Message :=
              Index
                (Source  => Line_Buffer (1 .. Line_Len),
                 Pattern => ": warning:") = 0;
         end if;

         if Is_Error_Message then
            Error_Message_Found := True;

            if Index (Source  => Line_Buffer (1 .. Line_Len),
                      Pattern => "BUG DETECTED") /= 0
            then
               --  If there is a bug box, we should skip the rest of
               --  processing to avoid storing some completely unmanageable
               --  (for diagnoses storage) diagnoses
               exit;
            end if;

            if Index (Source  => Line_Buffer (1 .. Line_Len),
                      Pattern => ":") /= 0
            then
               --  We should not store very general messages that do not
               --  contain SLOCs (such as "compilation abandoned", otherwise
               --  we get problems when messages are sorted.
               Store_Diagnosis
                 (Text               => Line_Buffer (1 .. Line_Len),
                  Diagnosis_Kind     => Compiler_Error,
                  SF                 => SF);
            end if;
         end if;

      end loop;

      if not Error_Message_Found then
         Store_Diagnosis
           (Text               => Short_Source_Name (SF) &
                                  ":1:1: cannot be compiled by unknown reason",
            Diagnosis_Kind     => Compiler_Error,
            SF                 => SF);
      end if;

      Close (Comp_Out_File);
   end Store_Error_Messages;

   ------------------------
   -- Turn_Off_Exemption --
   ------------------------

   procedure Turn_Off_Exemption
     (Rule         : Rule_Id;
      Closing_Span : Asis.Text.Span;
      SF           : SF_Id)
   is
      Tmp : Postponed_Rule_Exemption_Info_Access;
   begin
      --  Special processing for global rules, rules checked on expanded
      --  generics and compiler checks is not implemented yet

      if Needs_Postponed_Exemption_Processing (Rule) then
         --  Store compiler check exemption section
         Exemption_Sections (Rule).Line_End := Closing_Span.Last_Line;
         Exemption_Sections (Rule).Col_End  := Closing_Span.Last_Column;

         Tmp := new Postponed_Rule_Exemption_Info'
                      (Exemption_Section      => Exemption_Sections (Rule),
                       SF                     => SF,
                       Next_Exemption_Section => null);

         if Postponed_Exemption_Sections (Rule) (SF) = null then
            Postponed_Exemption_Sections (Rule) (SF) := Tmp;
         else
            Current_Postponed_Exemption_Sections (Rule).
              Next_Exemption_Section := Tmp;
         end if;

         Current_Postponed_Exemption_Sections (Rule) := Tmp;
      end if;

      if Exemption_Sections (Rule).Detected = 0
        and then
         not (Needs_Postponed_Exemption_Processing (Rule))
      then
         --  No one needs Justification
         Free (Exemption_Sections (Rule).Justification);

         Store_Diagnosis
           (Text           => Short_Source_Name (SF) & ':'                  &
                              Image (Closing_Span.Last_Line) & ':'          &
                              Image (Closing_Span.Last_Column)              &
                              ": no detection for "                         &
                              Rule_Name (Rule)                              &
                              " rule in exemption section starting at line" &
                               Exemption_Sections (Rule).Line_Start'Img,
            Diagnosis_Kind     => Exemption_Warning,
            SF                 => SF);

      end if;

      Exemption_Sections (Rule).Line_Start    := 0;
      Exemption_Sections (Rule).Col_Start     := 0;
      Exemption_Sections (Rule).Line_End      := 0;
      Exemption_Sections (Rule).Col_End       := 0;
      Exemption_Sections (Rule).Justification := null;
      Exemption_Sections (Rule).Detected      := 0;

   end Turn_Off_Exemption;

end Gnatcheck.Diagnoses;
