------------------------------------------------------------------------------ -- -- -- 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-2018, 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 3, 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 COPYING3. If -- -- not, go to http://www.gnu.org/licenses for a complete copy of the -- -- license. -- -- -- -- GNATCHECK is maintained by AdaCore (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ pragma Ada_2012; 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 GNAT.Directory_Operations; with Gnatvsn; use Gnatvsn; with Asis.Elements; use Asis.Elements; with Asis.Expressions; use Asis.Expressions; with Asis.Extensions.Strings; use Asis.Extensions.Strings; with Asis.Text; use Asis.Text; with ASIS_UL.Common; use ASIS_UL.Common; with ASIS_UL.Compiler_Options; with ASIS_UL.Debug; 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.Projects.Aggregate; use ASIS_UL.Projects.Aggregate; 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_Than (L, R : Diag_Message) return Boolean; function Diag_Is_Less_Than_Old (L, R : Diag_Message) return Boolean; pragma Unreferenced (Diag_Is_Less_Than_Old); -- 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 than 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. -- -- !!! Note, that this function is not a correct "<" relation in respect to -- what is needed by Ordered Sets container! Suppose we have two diagnostic -- messages generated for a source: -- -- foo.ads:100:10: something is bad - D1 -- foo.ads:100:10: because of this - D2 -- -- Suppose that they are stored in the diagnoses container. For these -- messages we have Diag_Is_Less_Than (D1, D2) is TRUE because of Num parts -- comparison. Suppose we have got them again (when compiling another -- source that depends on foo.ads). We will get another Diag_Message object -- for the first message (let's call it D3), and it will have Num part that -- will be greater than D2.Num. So if we -- compare Diag_Is_Less_Than (D3, D2), the result will be FALSE, but D1 and -- D3 will be representing the same diagnosis. The bad consequence of this -- is that we may get duplications of a diagnosis when using -- Error_Messages_Storage.Insert. See the body of Store_Diagnosis for the -- workaround we are using to avoid this. -- -- Diag_Is_Less_Than_Old assumes the old format of SLOC for expanded -- generic (with []) -- -- ??? Some better approach needed!!! 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_Than, "=" => 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; Ignored_Sources : 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_Str : constant String := "gnatcheck-source-list.out"; function Source_List_File_Name return String; -- Name of the file with all the argument file names created by -- gnatcheck if a used-provided file cannot be used for this. Ignored_Source_List_File_Name_Str : constant String := "gnatcheck-ignored-source-list.out"; function Ignored_Source_List_File_Name return String; -- Name of the file with the argument file names that has been ignored by -- the gnatcheck run. Rule_List_File_Name_Str : constant String := "gnatcheck-rule-list.out"; function Rule_List_File_Name return String; -- 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. Number : String_Access; -- Used when processing individual projects as a part of aggregate project -- processing. Represents a numeric index (prepended by "_") that is -- taken from the report file name. 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_Ignored_File_List_File; -- Prints the reference to the artificially created file that contains the -- list of files passed to gnatcheck that have not been processed because -- '--ignore=...' option. Note that it can be different from the list -- provided by '--ignore=...' option - this list contains only the existing -- files that have been passed as tool argument sources. procedure Print_Gnatcheck_Command_Line (XML : Boolean := False); -- 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. If XML is ON, prints -- the output into XML output file, otherwise - in the text output file. 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_Runtime (XML : Boolean := False); -- Prints the runtime version used for gnatcheck call. It is either the -- parameter of --RTS option used for (actual) gnatcheck call or the -- "" string if --RTS parameter is not specified. If XML is ON, -- prints the output into XML output file, otherwise - in the text output -- file. procedure Print_Violation_Summary; -- Prints the total numbers of: non-exempted)violations, exempted -- violations, exemption warnings and compiler errors. procedure XML_Report_Diagnosis (Diag : Diag_Message; Short_Report : Boolean); -- Prints into XML report file the information from the diagnosis. The -- boolean parameter is used to define the needed indentation level function Select_Line (Diag : String_Access) return Positive; function Select_Column (Diag : String_Access) return Positive; -- Assuming that Diag is a diagnosis, gets the line/column 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 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). 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. ----------------------------- -- Parametric exemptions -- ----------------------------- Rule_Exemption_Parameters : Exemption_Parameters.Set; -- Temporary place for collecting rule parameters in case if exemption -- specifies parameters for a rule. type Parametrized_Exemption_Info is record Exempt_Info : Exemption_Info; Rule : Rule_Id; SF : SF_Id; Params : String_List_Access; end record; type Param_Ex_Info_Key is record SF : SF_Id; Line_Start : Natural; Col_Start : Natural; end record; function Key (Element : Parametrized_Exemption_Info) return Param_Ex_Info_Key is (SF => Element.SF, Line_Start => Element.Exempt_Info.Line_Start, Col_Start => Element.Exempt_Info.Col_Start); function "<" (L, R : Param_Ex_Info_Key) return Boolean is (L.SF < R.SF or else (L.SF = R.SF and then ((L.Line_Start < R.Line_Start) or else (L.Line_Start = R.Line_Start and then L.Col_Start < R.Col_Start)))); function Is_Equal (L, R : String_List_Access) return Boolean; -- Checks if L and R have the same content. function Is_Equal (L : Exemption_Parameters.Set; R : String_List_Access) return Boolean; -- Checks that L and R are both non-empty/non-null and have the same -- content. function Belongs (L : String; R : String_List_Access) return Boolean; -- Checks if R is non-null and L belongs to R function To_Pars_List (Pars : Exemption_Parameters.Set) return String_List_Access; -- Converts (non-empty! the caller is responsible for that!) set of rule -- exemption parameters into string list. function Params_Img (Params : String_List_Access; Rule : Rule_Id) return String; -- Returns the string image of rule exemption parameters that are supposed -- to be stored in Params list (and Params is supposed to be not null) in -- the format suitable for including in a diagnosis. Rule parameter is -- needed to decide if we should fold the parameter in proper case (for -- sure we should not do this for Warnings rule) function "=" (L, R : Parametrized_Exemption_Info) return Boolean is (L.SF = R.SF and then Is_Equal (L.Params, R.Params) and then L.Exempt_Info.Line_Start = R.Exempt_Info.Line_Start and then L.Exempt_Info.Col_Start = R.Exempt_Info.Col_Start); function "<" (L, R : Parametrized_Exemption_Info) return Boolean is (L.SF < R.SF or else (L.SF = R.SF and then ((L.Exempt_Info.Line_Start < R.Exempt_Info.Line_Start) or else (L.Exempt_Info.Line_Start = R.Exempt_Info.Line_Start and then L.Exempt_Info.Col_Start < R.Exempt_Info.Col_Start)))); package Parametrized_Exemption_Sections is new Ada.Containers.Ordered_Sets (Parametrized_Exemption_Info); package Exem_Section_Keys is new Parametrized_Exemption_Sections.Generic_Keys (Key_Type => Param_Ex_Info_Key, Key => Key); -- ??? Should be documented!!! type Rule_Param_Exempt_Sections_Type is array (Rule_Id range <>) of Parametrized_Exemption_Sections.Set; type Rule_Param_Exempt_Sections_Access is access Rule_Param_Exempt_Sections_Type; Rule_Param_Exempt_Sections : Rule_Param_Exempt_Sections_Access; -- Stores parametric exemption sections for a source being processed procedure Set_Rule_Exempt_Pars (Rule : Rule_Id; Pars : String; SF : SF_Id; SLOC : String); -- Assuming that Rule is a rule that allows parametric expressions, -- and Pars is a part of a third argument of a rule exemption pragma that -- contains rule parameters, parses Pars string and checks if each of the -- specified parameters indeed can be used as rule exemption parameter. -- If all the parameters can be used in rule exemption, all of them are -- placed into the value of Rule_Exemption_Parameters set variable. If -- some parameter is wrong, and error message is generated and -- Rule_Exemption_Parameters sets to empty set. Note that if immediately -- after a call to this subprogram Rule_Exemption_Parameters is empty, then -- the corresponding exemption pragma is incorrect. -- Parameters SF and SLOC are needed to form an error message - this -- procedure does not have any ASIS Element to compute it from. They should -- correspond to a pragma parameter denoting a rule (and parameters) function Allows_Parametrized_Exemption (Rule : Rule_Id) return Boolean; -- Checks if Rule allows fine-tuned exemption (with specifying parameters -- for that it can be exempted). Assumes Present (Rule). function Allowed_As_Exemption_Parameter (Rule : Rule_Id; Param : String) return Boolean; -- Checks if Param is allowed as a rule parameter in rule exemption pragma. -- Assumes that Param has already folded to lower case. Always returns -- False if Allows_Prametrized_Exemption (Rule) is False. procedure Is_Exempted_With_Pars (Rule : Rule_Id; Exempted_At : out Parametrized_Exemption_Sections.Cursor); -- Checks if Rule is already exempted with the set of parameters that are -- stored in the global Rule_Exemption_Parameters variable. If it does then -- Exempted_At is set to the set cursor pointing to the corresponding -- exemption section in Rule_Param_Exempt_Sections, otherwise Exempted_At -- is set to No_Element. The check is made for the parametric exemption -- sections that are currently opened in the source being traversed and -- stored in Rule_Param_Exempt_Sections (see below). This procedure is -- supposed to use only in Process_Exemption_Pragma, it depends on the -- specific calling context created when analyzing a rule exemption pragma. procedure Same_Parameter_Exempted (Rule : Rule_Id; Exempted_At : out Parametrized_Exemption_Sections.Cursor; Par : out String_Access); -- Is similar to the previous procedure, but it checks that there is at -- least one parameter in Rule_Exemption_Parameters that has already been -- used in definition of some opened parametric exception section for -- this rule: -- -- Exempt_On, Rule:Par1, Par3 -- ... -- Exempt_On, Rule:Par1, Par2 -- -- If the checks succeeds, Par is set to point to this parameter. The -- caller is responsible for freeing the memory occupied by Par. function Get_Param_Justification (Rule : Rule_Id; Diag : String; SF : SF_Id; Line : Natural := 0; Col : Natural := 0; Check_Postponed_Exemptions : Boolean := False) return String_Access; -- Diag is supposed to be a diagnostic message (with all the parameters -- and variants resolved) generated for Rule (and Rule should allow -- parametric exemptions). It checks if Text corresponds to some -- parametric section for this Rule. If Check_Postponed_Exemptions is ON, -- the check is made for stored for postponed analysis parametric -- exemption sections, otherwise the check is considered as performed for -- the currently analyzed source and information about parametric exemption -- sections from Rule_Param_Exempt_Sections is used. -- If Diag fits into an exemption section, the result is the pointer to the -- corresponding justification and the diagnostic counter for this section -- is increased as a side effect of the function call. Otherwise the result -- is null. -- Parameters Line and Col are used only if Check_Postponed_Exemptions, -- they should be set to the line and column numbers from the diagnosis. -- If we analyze the diagnosis against postponed exemptions, we have the -- full set of exemption sections for SF, so Line and Col are used to -- filter out sections the diagnosis does not get into, and they -- allow to break iterating through sections when we have visited all that -- start before the diagnosis. -- -- If Check_Postponed_Exemptions is OFF, the set of exemption sections -- stored in Rule_Param_Exempt_Sections for Rule contains all those and -- only those sections that covers the SLOC of diagnosis, so we do not need -- Line and Col from the text of the diagnosis. function Rule_Parameter (Diag : String; Rule : Rule_Id) return String; -- Provided that Rule allows parametric exemptions, and Diag is a -- diagnostic message corresponding to this rule, defines the rule -- exemption parameter Diag corresponds to. function Get_Exem_Section (Exem_Sections : Parametrized_Exemption_Sections.Set; Param : String; Line : Natural := 0; Col : Natural := 0; Check_Postponed_Exemptions : Boolean := False) return Parametrized_Exemption_Sections.Cursor; -- Tries to locate in Exem_Sections the section that exempts the rule this -- Param is supposed to corresponds to (choosing the right set of exemption -- sections should be done outside the call) with Param. Returns -- No_Element if the attempt fails. -- If Check_Postponed_Exemptions is ON, the function uses Line and Col to -- optimize iteration through Exem_Sections (see comment to -- Get_Param_Justification procedure Icrease_Diag_Counter (Exem_Sections : in out Parametrized_Exemption_Sections.Set; Section : Parametrized_Exemption_Sections.Cursor); -- Adds 1 to the counter of detected violations for the exemption sections -- pointed by Section in Exem_Sections. procedure Turn_Off_Parametrized_Exemption (Rule : Rule_Id; Exempted_At : in out Parametrized_Exemption_Sections.Cursor; 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. --------------------------------------------------- -- Parametric exemptions for postponed checks -- --------------------------------------------------- type Per_Source_Postponed_Param_Exemp is array (SF_Id range <>) of Parametrized_Exemption_Sections.Set; type Per_Source_Postponed_Param_Exemp_Access is access Per_Source_Postponed_Param_Exemp; type Per_Rule_Postponed_Param_Exemp is array (Rule_Id range <>) of Per_Source_Postponed_Param_Exemp_Access; type Per_Rule_Postponed_Param_Exemp_Access is access Per_Rule_Postponed_Param_Exemp; Postponed_Param_Exempt_Sections : Per_Rule_Postponed_Param_Exemp_Access; -- Here we collect all the parametric exemption sections for postponed -- checks. --------------------------------------------- -- Debug routines for exemption mechanism -- --------------------------------------------- procedure Parametrized_Exem_Section_Debug_Image (S : Parametrized_Exemption_Sections.Cursor); -- Prints out the debug image of the information stored for a parametric -- exemption section. procedure Rule_Parametrized_Exem_Sections_Debug_Image (Rule : Rule_Id); pragma Unreferenced (Rule_Parametrized_Exem_Sections_Debug_Image); -- Prints out the debug image of the current state of the information about -- parametric exemption sections stored for Rule in -- Rule_Param_Exempt_Sections 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?) ---------------------------- -- 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; <> return Result; end All_Sources_In_One_File; ------------------------------------ -- Allowed_As_Exemption_Parameter -- ------------------------------------ function Allowed_As_Exemption_Parameter (Rule : Rule_Id; Param : String) return Boolean is Result : Boolean := False; begin if not Allows_Parametrized_Exemption (Rule) then return False; end if; case Rule is when Restrictions_Id => Result := Is_Restriction_Exemption_Par (Param); when Style_Checks_Id => null; when Warnings_Id => Result := Is_Warning_Exemption_Par (Param); when others => Result := Allowed_As_Exemption_Parameter (All_Rules.Table (Rule).all, Param); end case; return Result; end Allowed_As_Exemption_Parameter; ----------------------------------- -- Allows_Parametrized_Exemption -- ----------------------------------- function Allows_Parametrized_Exemption (Rule : Rule_Id) return Boolean is Result : Boolean := False; begin case Rule is when Restrictions_Id | Warnings_Id => Result := True; when Style_Checks_Id => null; when others => Result := Allows_Parametrized_Exemption (All_Rules.Table (Rule).all); end case; return Result; end Allows_Parametrized_Exemption; function Belongs (L : String; R : String_List_Access) return Boolean is Result : Boolean := False; begin if R /= null then for J in R'Range loop if L = R (J).all then Result := True; exit; elsif R (J).all > L then exit; end if; end loop; end if; return Result; end Belongs; ------------------------------------ -- Check_Unclosed_Rule_Exemptions -- ------------------------------------ procedure Check_Unclosed_Rule_Exemptions (SF : SF_Id; Unit : Asis.Element) is Comp_Span : constant Span := Compilation_Span (Unit); use Parametrized_Exemption_Sections; Next_Section : Cursor; begin -- Non-parametric exemptions: 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; -- Parametric exemptions: for Rule in Rule_Param_Exempt_Sections'Range loop if Allows_Parametrized_Exemption (Rule) and then not Is_Empty (Rule_Param_Exempt_Sections (Rule)) then -- We cannot use set iterator here - we need to use Rule and SF -- into processing routine Next_Section := First (Rule_Param_Exempt_Sections (Rule)); while Has_Element (Next_Section) loop Store_Diagnosis (Text => Short_Source_Name (SF) & ':' & Image (Parametrized_Exemption_Sections.Element (Next_Section).Exempt_Info.Line_Start) & ':' & Image (Parametrized_Exemption_Sections.Element (Next_Section).Exempt_Info.Col_Start) & ": " & "No matching 'exempt_OFF' annotation " & "for rule " & Rule_Name (Rule), Diagnosis_Kind => Exemption_Warning, SF => SF); Turn_Off_Parametrized_Exemption (Rule, Next_Section, Comp_Span, SF); Next_Section := First (Rule_Param_Exempt_Sections (Rule)); end loop; 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 if not Is_Argument_Source (SF) then -- All the statistics is collected for argument files only! return; end if; 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 | Not_A_Legal_Source_Needs_Listing_Processing | 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 if Text_Report_ON then Report (Line_Buf (1 .. Line_Len)); end if; if XML_Report_ON then XML_Report (Line_Buf (1 .. Line_Len), 1); end if; 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_Than -- ----------------------- function Diag_Is_Less_Than (L, R : Diag_Message) return Boolean is L_First : constant Natural := L.Text'First; R_First : constant Natural := R.Text'First; 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 := False; R_Has_Chain : Boolean := False; Inst_Idx : Natural; Tmp_Idx : Natural; Result : Boolean; begin if Diag_Is_Equal (L, R) then return False; end if; -- For computing L_Has_Chain and R_Has_Chain we have to check not only -- the presence of Instance_SLOC_Txt in the diagnosis, but also to -- verify that it is used as a SLOC of the diagnoses, but not as some -- part of diagnoses text (some refinement etc.) Inst_Idx := Index (L.Text.all, Instance_SLOC_Txt); if Inst_Idx > 0 then Tmp_Idx := Index (L.Text.all, "("); L_Has_Chain := Tmp_Idx = 0 or else Inst_Idx < Tmp_Idx; end if; Inst_Idx := Index (R.Text.all, Instance_SLOC_Txt); if Inst_Idx > 0 then Tmp_Idx := Index (R.Text.all, "("); R_Has_Chain := Tmp_Idx = 0 or else Inst_Idx < Tmp_Idx; end if; if L_Has_Chain then L_SLOC_Start := Index (L.Text (L_First .. L_SLOC_End), " ", Going => Backward) + 1; else L_SLOC_Start := L_First; end if; if R_Has_Chain then R_SLOC_Start := Index (R.Text (R_First .. R_SLOC_End), " ", Going => Backward) + 1; else R_SLOC_Start := R_First; end if; Result := SLOC_Less_Than (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_First; R_SLOC_Start := R_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_Than (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_Than; function Diag_Is_Less_Than_Old (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_Than (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_Than (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_Than_Old; ----------------------------- -- 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 (""); 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 Number := new String'(Get_Number); Ignored_Sources := Exempted_Sources; Process_Postponed_Exemptions; Compute_Statisctics; if XML_Report_ON then XML_Report (""); XML_Report_No_EOL (""); else XML_Report (">"); end if; end if; -- OVERVIEW if not Short_Report then Print_Report_Header; Print_Active_Rules_File; Print_File_List_File; Print_Ignored_File_List_File; Print_Argument_Files_Summary; if Text_Report_ON then Report_EOL; end if; Print_Violation_Summary; -- Print_Failure_Info; -- 2. DETECTED EXEMPTED RULE VIOLATIONS if Text_Report_ON then Report_EOL; Report ("2. Exempted Coding Standard Violations"); Report_EOL; end if; if XML_Report_ON then XML_Report (""); end if; 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 if Text_Report_ON then Report ("no exempted violations detected", 1); end if; if not Short_Report and then XML_Report_ON then XML_Report ("no exempted violations detected", 1); end if; end if; if not Short_Report then if Text_Report_ON then Report_EOL; Report ("3. Non-exempted Coding Standard Violations"); Report_EOL; end if; 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 if Text_Report_ON then Report ("no non-exempted violations detected", 1); end if; if not Short_Report and then XML_Report_ON then XML_Report ("no non-exempted violations detected", 1); end if; end if; if not Short_Report then if Text_Report_ON then Report_EOL; Report ("4. Rule exemption problems"); Report_EOL; end if; end if; if Detected_Exemption_Warning > 0 then Diagnoses_To_Print := (Rule_Violation => False, Exemption_Warning => True, Compiler_Error => False); Print_Diagnoses; else if Text_Report_ON then Report ("no rule exemption problems detected", 1); end if; if not Short_Report and then XML_Report_ON then XML_Report ("no rule exemption problems detected", 1); end if; end if; if not Short_Report then if Text_Report_ON then Report_EOL; Report ("5. Language violations"); Report_EOL; end if; end if; if Detected_Compiler_Error > 0 then Diagnoses_To_Print := (Rule_Violation => False, Exemption_Warning => False, Compiler_Error => True); Print_Diagnoses; else if Text_Report_ON then Report ("no language violations detected", 1); end if; if not Short_Report and then XML_Report_ON then XML_Report ("no language violations detected", 1); end if; end if; -- User-defined part if not Short_Report then if XML_Report_ON then XML_Report (""); end if; if Text_Report_ON then Report_EOL; end if; if User_Info_File /= null then if Text_Report_ON then Report ("6. Additional Information"); Report_EOL; end if; if XML_Report_ON then XML_Report (""); end if; Copy_User_Info; if Text_Report_ON then Report_EOL; end if; if XML_Report_ON then XML_Report (""); end if; end if; end if; if XML_Report_ON then XML_Report (""); 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_Exem_Section -- ---------------------- function Get_Exem_Section (Exem_Sections : Parametrized_Exemption_Sections.Set; Param : String; Line : Natural := 0; Col : Natural := 0; Check_Postponed_Exemptions : Boolean := False) return Parametrized_Exemption_Sections.Cursor is use Parametrized_Exemption_Sections; Result : Cursor := No_Element; Next_Section : Cursor := First (Exem_Sections); Diag_In_Section : Boolean := True; Diag_Before_Sections : Boolean := False; -- These two Boolean flags are used only if Check_Postponed_Exemptions -- is ON to control iterating through all the parametric exemption -- sections for the source that are stored in Exem_Sections Next_Section_El : Parametrized_Exemption_Info; begin while Has_Element (Next_Section) loop Next_Section_El := Parametrized_Exemption_Sections.Element (Next_Section); if Check_Postponed_Exemptions then Diag_Before_Sections := Line < Next_Section_El.Exempt_Info.Line_Start or else (Line = Next_Section_El.Exempt_Info.Line_Start and then Col < Next_Section_El.Exempt_Info.Col_Start); exit when Diag_Before_Sections; Diag_In_Section := (Line > Next_Section_El.Exempt_Info.Line_Start or else (Line = Next_Section_El.Exempt_Info.Line_Start and then Col > Next_Section_El.Exempt_Info.Col_Start)) and then (Line < Next_Section_El.Exempt_Info.Line_End or else (Line = Next_Section_El.Exempt_Info.Line_End and then Col < Next_Section_El.Exempt_Info.Col_End)); end if; if Diag_In_Section and then Belongs (Param, Next_Section_El.Params) then Result := Next_Section; exit; end if; Next_Section := Next (Next_Section); end loop; return Result; end Get_Exem_Section; ------------------------ -- 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, Instance_SLOC_Txt); 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; ----------------------------- -- Get_Param_Justification -- ----------------------------- function Get_Param_Justification (Rule : Rule_Id; Diag : String; SF : SF_Id; Line : Natural := 0; Col : Natural := 0; Check_Postponed_Exemptions : Boolean := False) return String_Access is Result : String_Access; use Parametrized_Exemption_Sections; Exem_Sections : access Parametrized_Exemption_Sections.Set; -- You should never assign containers!!! Fit_In_Section : Cursor; begin if Needs_Postponed_Exemption_Processing (Rule) and then not Check_Postponed_Exemptions then return null; end if; declare Param : constant String := Rule_Parameter (Diag, Rule); pragma Assert (Param /= "" or else Rule = Warnings_Id); begin if Check_Postponed_Exemptions then Exem_Sections := Postponed_Param_Exempt_Sections (Rule) (SF)'Unrestricted_Access; else Exem_Sections := Rule_Param_Exempt_Sections (Rule)'Unrestricted_Access; end if; Fit_In_Section := Get_Exem_Section (Exem_Sections.all, Param, Line, Col, Check_Postponed_Exemptions); if Has_Element (Fit_In_Section) then Result := Parametrized_Exemption_Sections.Element (Fit_In_Section). Exempt_Info.Justification; Icrease_Diag_Counter (Exem_Sections.all, Fit_In_Section); end if; end; return Result; end Get_Param_Justification; -------------------------- -- Icrease_Diag_Counter -- -------------------------- procedure Icrease_Diag_Counter (Exem_Sections : in out Parametrized_Exemption_Sections.Set; Section : Parametrized_Exemption_Sections.Cursor) is procedure Add_One (Exem_Section : in out Parametrized_Exemption_Info); procedure Add_One (Exem_Section : in out Parametrized_Exemption_Info) is begin Exem_Section.Exempt_Info.Detected := Exem_Section.Exempt_Info.Detected + 1; end Add_One; begin Exem_Section_Keys.Update_Element_Preserving_Key (Container => Exem_Sections, Position => Section, Process => Add_One'Access); end Icrease_Diag_Counter; ----------------------------------- -- Ignored_Source_List_File_Name -- ----------------------------------- function Ignored_Source_List_File_Name return String is Dot_Idx : constant Natural := Index (Ignored_Source_List_File_Name_Str, ".", Forward); begin if not Aggregated_Project then return Ignored_Source_List_File_Name_Str; end if; pragma Assert (Dot_Idx > 0); return Ignored_Source_List_File_Name_Str (Ignored_Source_List_File_Name_Str'First .. Dot_Idx - 1) & Number.all & Ignored_Source_List_File_Name_Str (Dot_Idx .. Ignored_Source_List_File_Name_Str'Last); end Ignored_Source_List_File_Name; --------------------- -- 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; -- Parametric exemptions: Rule_Param_Exempt_Sections := new Rule_Param_Exempt_Sections_Type (First_Compiler_Check .. All_Rules.Last); Postponed_Param_Exempt_Sections := new Per_Rule_Postponed_Param_Exemp (First_Compiler_Check .. All_Rules.Last); for Rule in Postponed_Exemption_Sections'Range loop if Needs_Postponed_Exemption_Processing (Rule) and then Allows_Parametrized_Exemption (Rule) then Postponed_Param_Exempt_Sections (Rule) := new Per_Source_Postponed_Param_Exemp (First_SF_Id .. Last_Argument_Source); 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_Equal -- -------------- function Is_Equal (L, R : String_List_Access) return Boolean is Result : Boolean := (L = null) and (R = null); R_Idx : Natural; begin if L /= null and then R /= null and then L'Length = R'Length then R_Idx := R'First; Result := True; for J in L'Range loop if L (J) = null or else R (R_Idx) = null then -- Even if both elements are null we return False because this -- cannot be considered as the same sequence of parameters Result := False; exit; elsif L (J).all /= R (R_Idx).all then Result := False; exit; end if; R_Idx := R_Idx + 1; end loop; end if; return Result; end Is_Equal; function Is_Equal (L : Exemption_Parameters.Set; R : String_List_Access) return Boolean is use Exemption_Parameters; Result : Boolean := not Is_Empty (L) and then R /= null and then Natural (Length (L)) = R'Length; begin if Result then declare L_Arr : String_List_Access := To_Pars_List (L); begin Result := Is_Equal (L_Arr, R); Free (L_Arr); end; end if; return Result; end Is_Equal; ----------------- -- Is_Exempted -- ----------------- function Is_Exempted (Rule : Rule_Id) return Boolean is begin return Exemption_Sections (Rule).Line_Start > 0; end Is_Exempted; --------------------------- -- Is_Exempted_With_Pars -- --------------------------- procedure Is_Exempted_With_Pars (Rule : Rule_Id; Exempted_At : out Parametrized_Exemption_Sections.Cursor) is use Parametrized_Exemption_Sections; Next_Section : Cursor; begin Exempted_At := No_Element; if not Is_Empty (Rule_Param_Exempt_Sections (Rule)) then Next_Section := First (Rule_Param_Exempt_Sections (Rule)); while Has_Element (Next_Section) loop if Is_Equal (Rule_Exemption_Parameters, Parametrized_Exemption_Sections.Element (Next_Section).Params) then Exempted_At := Next_Section; exit; end if; Next_Section := Next (Next_Section); end loop; end if; end Is_Exempted_With_Pars; ------------------------- -- 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 not Is_Argument_Source (In_File) then -- Exemption sections are processed in argument files only! return; end if; 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; ------------------------------------------- -- Parametrized_Exem_Section_Debug_Image -- ------------------------------------------- procedure Parametrized_Exem_Section_Debug_Image (S : Parametrized_Exemption_Sections.Cursor) is ES_Info : Parametrized_Exemption_Info; begin if Parametrized_Exemption_Sections.Has_Element (S) then ES_Info := Parametrized_Exemption_Sections.Element (S); Info ("+++++++++++++++++++++++++++++++++++++++++++++++"); Info_No_EOL ("parametric exemption section for rule"); Info (ES_Info.Rule'Img & "(" & Rule_Name (ES_Info.Rule) & ")"); Info ("in file SF=" & ES_Info.SF'Img & "(" & Short_Source_Name (ES_Info.SF) & ")"); Info ("Parameters:"); if ES_Info.Params = null then Info (" Null parameter list!!!"); elsif ES_Info.Params'Length = 0 then Info (" Empty parameter list!!!"); else for J in ES_Info.Params'Range loop Info (">>" & ES_Info.Params (J).all & "<<"); end loop; end if; Info ("Span: " & ES_Info.Exempt_Info.Line_Start'Img & ":" & ES_Info.Exempt_Info.Col_Start'Img & " -" & ES_Info.Exempt_Info.Line_End'Img & ":" & ES_Info.Exempt_Info.Col_End'Img); Info ("Detected :" & ES_Info.Exempt_Info.Detected'Img); Info_No_EOL ("Justification: "); if ES_Info.Exempt_Info.Justification = null then Info ("IS NOT SET!!!"); else Info (">>" & ES_Info.Exempt_Info.Justification.all & "<<"); end if; else Info ("No parametric exemption section"); end if; end Parametrized_Exem_Section_Debug_Image; ---------------- -- Params_Img -- ---------------- function Params_Img (Params : String_List_Access; Rule : Rule_Id) return String is Res_Len : Natural := 0; begin pragma Assert (Params /= null); for J in Params'Range loop Res_Len := Res_Len + Params (J)'Length; end loop; Res_Len := Res_Len + (Params'Length - 1) * 2; -- for ", " declare Result : String (1 .. Res_Len); Append_From : Natural := Result'First; begin for J in Params'Range loop if J > Params'First then Result (Append_From .. Append_From + 1) := ", "; Append_From := Append_From + 2; end if; Result (Append_From .. Append_From + Params (J)'Length - 1) := (if Rule = Warnings_Id then Params (J).all else Proper_Case (Params (J).all)); Append_From := Append_From + Params (J)'Length; end loop; return Result; end; end Params_Img; -------------------------------------- -- 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 ("***Postponed non-parametric 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 ("***Postponed non-parametric exemptions debug image end"); Info (""); Info ("***Postponed parametric exemptions debug image start"); for SF in First_SF_Id .. Last_Argument_Source loop Info ("***PARAMETRIC Exemption sections for " & Short_Source_Name (SF)); for Rule in Postponed_Param_Exempt_Sections'Range loop if Allows_Parametrized_Exemption (Rule) and then Needs_Postponed_Exemption_Processing (Rule) then Info ("** Rule " & Rule_Name (Rule)); if Parametrized_Exemption_Sections.Is_Empty (Postponed_Param_Exempt_Sections (Rule) (SF)) then Info (" No parametric exemption sections"); else Parametrized_Exemption_Sections.Iterate (Container => Postponed_Param_Exempt_Sections (Rule) (SF), Process => Parametrized_Exem_Section_Debug_Image'Access); end if; end if; end loop; end loop; Info ("***Postponed parametric 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 if Text_Report_ON then Report_No_EOL ("coding standard : "); end if; if XML_Report_ON then XML_Report_No_EOL (" 1); end if; if not Individual_Rules_Set and then Rule_File_Name /= null then if Text_Report_ON then Report (Rule_File_Name.all); end if; if XML_Report_ON then XML_Report (Rule_File_Name.all & """>"); end if; else -- Creating the list of active rules in Rule_List_File_Name declare Full_Rule_List_File_Name : constant String := (if Get_Report_File_Name /= "" then GNAT.Directory_Operations.Dir_Name (Get_Report_File_Name) else GNAT.Directory_Operations.Dir_Name (Get_XML_Report_File_Name)) & Rule_List_File_Name; begin if Is_Regular_File (Full_Rule_List_File_Name) then Open (Rule_List_File, Out_File, Full_Rule_List_File_Name); else Create (Rule_List_File, Out_File, Full_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); if Text_Report_ON then Report (Rule_List_File_Name); end if; if XML_Report_ON then XML_Report (Rule_List_File_Name & """>"); end if; end; end if; if XML_Report_ON then 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 XML_Print_Rule (All_Rules.Table (Rule).all, Indent_Level => 2); end if; end loop; if Use_gnaty_Option then XML_Report ("", Indent_Level => 2); XML_Report ("" & Get_Style_Option (Get_Style_Option'First + 6 .. Get_Style_Option'Last) & "", Indent_Level => 3); XML_Report ("", Indent_Level => 2); end if; if Use_gnatw_Option then XML_Report ("", Indent_Level => 2); XML_Report ("" & Get_Specified_Warning_Option (Get_Specified_Warning_Option'First + 6 .. Get_Specified_Warning_Option'Last) & "", Indent_Level => 3); XML_Report ("", Indent_Level => 2); end if; if Check_Restrictions then XML_Print_Active_Restrictions (Indent_Level => 1); end if; XML_Report ("", Indent_Level => 1); end if; end Print_Active_Rules_File; ---------------------------------- -- Print_Argument_Files_Summary -- ---------------------------------- procedure Print_Argument_Files_Summary is begin if Text_Report_ON then 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); Report ("ignored sources :" & Ignored_Sources'Img, 1); end if; if XML_Report_ON then XML_Report (""); XML_Report ("" & Image (Fully_Compliant_Sources) & "", Indent_Level => 1); XML_Report ("" & Image (Sources_With_Exempted_Violations) & "", Indent_Level => 1); XML_Report ("" & Image (Sources_With_Violations) & "", Indent_Level => 1); XML_Report ("" & Image (Unverified_Sources) & "", Indent_Level => 1); XML_Report ("" & Image (Integer (Last_Argument_Source)) & "", Indent_Level => 1); end if; pragma Assert (Checked_Sources = Fully_Compliant_Sources + Sources_With_Violations + Sources_With_Exempted_Violations + Ignored_Sources); 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; if Text_Report_ON then Report (Diag.Text.all); if Diag.Justification /= null then Report ("(" & Diag.Justification.all & ")", 1); end if; end if; if XML_Report_ON then XML_Report_Diagnosis (Diag, Short_Report); 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 if Text_Report_ON then Report_No_EOL ("list of sources : "); end if; if XML_Report_ON then XML_Report_No_EOL (" 1); end if; if All_Sources_In_One_File then if Text_Report_ON then Report (Arg_Source_File_Name); end if; if XML_Report_ON then XML_Report (Arg_Source_File_Name & """>"); end if; else -- Creating the list of processed sources in Source_List_File_Name declare Full_Source_List_File_Name : constant String := (if Get_Report_File_Name /= "" then GNAT.Directory_Operations.Dir_Name (Get_Report_File_Name) else GNAT.Directory_Operations.Dir_Name (Get_XML_Report_File_Name)) & Source_List_File_Name; begin if XML_Report_ON then XML_Report (Source_List_File_Name & """>"); end if; if Is_Regular_File (Full_Source_List_File_Name) then Open (Source_List_File, Out_File, Full_Source_List_File_Name); else Create (Source_List_File, Out_File, Full_Source_List_File_Name); end if; for SF in First_SF_Id .. Last_Argument_Source loop if Source_Info (SF) /= Ignore_Unit then Put_Line (Source_List_File, (if Full_Source_Locations then Source_Name (SF) else Short_Source_Name (SF))); end if; end loop; Close (Source_List_File); if Text_Report_ON then Report (Source_List_File_Name); end if; end; end if; if Text_Report_ON then Report_EOL; end if; if XML_Report_ON then for SF in First_SF_Id .. Last_Argument_Source loop if XML_Report_ON and then Source_Info (SF) /= Ignore_Unit then XML_Report ("" & Source_Name (SF) & "", Indent_Level => 2); end if; end loop; XML_Report ("", Indent_Level => 1); end if; end Print_File_List_File; ---------------------------------- -- Print_Gnatcheck_Command_Line -- ---------------------------------- procedure Print_Gnatcheck_Command_Line (XML : Boolean := False) 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 if XML then XML_Report (GNAT_Driver_Call.all); else Report (GNAT_Driver_Call.all); end if; else if XML then XML_Report_No_EOL (Ada.Command_Line.Command_Name); else Report_No_EOL (Ada.Command_Line.Command_Name); end if; for Arg in 1 .. Ada.Command_Line.Argument_Count loop if XML then XML_Report_No_EOL (" " & Ada.Command_Line.Argument (Arg)); else Report_No_EOL (" " & Ada.Command_Line.Argument (Arg)); end if; end loop; if not XML then Report_EOL; end if; end if; end Print_Gnatcheck_Command_Line; ---------------------------------- -- Print_Ignored_File_List_File -- ---------------------------------- procedure Print_Ignored_File_List_File is Ignored_Source_List_File : Ada.Text_IO.File_Type; begin if Ignored_Sources = 0 then return; end if; if Text_Report_ON then Report_No_EOL ("list of ignored sources : "); end if; if XML_Report_ON then XML_Report_No_EOL (" 1); end if; declare Full_Ignored_Source_List_File_Name : constant String := (if Get_Report_File_Name /= "" then GNAT.Directory_Operations.Dir_Name (Get_Report_File_Name) else GNAT.Directory_Operations.Dir_Name (Get_XML_Report_File_Name)) & Ignored_Source_List_File_Name; begin if XML_Report_ON then XML_Report (Ignored_Source_List_File_Name & """>"); end if; if Is_Regular_File (Full_Ignored_Source_List_File_Name) then Open (Ignored_Source_List_File, Out_File, Full_Ignored_Source_List_File_Name); else Create (Ignored_Source_List_File, Out_File, Full_Ignored_Source_List_File_Name); end if; for SF in First_SF_Id .. Last_Argument_Source loop if Source_Info (SF) = Ignore_Unit then Put_Line (Ignored_Source_List_File, (if Full_Source_Locations then Source_Name (SF) else Short_Source_Name (SF))); end if; end loop; Close (Ignored_Source_List_File); if Text_Report_ON then Report (Ignored_Source_List_File_Name); end if; end; if Text_Report_ON then Report_EOL; end if; if XML_Report_ON then for SF in First_SF_Id .. Last_Argument_Source loop if XML_Report_ON and then Source_Info (SF) = Ignore_Unit then XML_Report ("" & Source_Name (SF) & "", Indent_Level => 2); end if; end loop; XML_Report ("", Indent_Level => 1); end if; end Print_Ignored_File_List_File; ------------------------- -- Print_Out_Diagnoses -- ------------------------- procedure Print_Out_Diagnoses is Diagnoses_Reported : Natural := 0; Limit_Exceeded : Boolean := False; GPS_Prefix : constant String := "check:"; function Add_GPS_Prefix (Diag : String) return String; -- If the corresponding option is set (at the moment it is '-dd' option -- that activates progress indicator, but this may be changed) adds -- GPS_Prefix to the diagnosis that is supposed to be passed as an -- actual. Otherwise returns the argument unchanged. procedure Counted_Print_Diagnosis (Position : Error_Messages_Storage.Cursor); function Add_GPS_Prefix (Diag : String) return String is Idx : Natural; Inst_Count : Natural; begin if ASIS_UL.Debug.Debug_Flag_D then Idx := Index (Diag, ": "); Inst_Count := Ada.Strings.Fixed.Count (Diag, Instance_SLOC_Txt); if Inst_Count = 0 then return Diag (Diag'First .. Idx + 1) & GPS_Prefix & ' ' & Diag (Idx + 2 .. Diag'Last); else declare Result : String (1 .. Diag'Length + Inst_Count + GPS_Prefix'Length); Res_Idx : Natural := Result'First; Diag_Start : Natural := Diag'First; Diag_End : Natural; Diag_Last : constant Natural := Diag'Last; begin while Inst_Count > 0 loop Diag_End := Index (Diag (Diag_Start .. Diag_Last), Instance_SLOC_Txt); Result (Res_Idx .. Res_Idx + (Diag_End - Diag_Start - 1)) := Diag (Diag_Start .. Diag_End - 1); Res_Idx := Res_Idx + (Diag_End - Diag_Start); Result (Res_Idx) := ':'; Res_Idx := Res_Idx + 1; Result (Res_Idx .. Res_Idx + Instance_SLOC_Txt'Length - 1) := Instance_SLOC_Txt; Res_Idx := Res_Idx + Instance_SLOC_Txt'Length; Diag_Start := Diag_End + Instance_SLOC_Txt'Length; Inst_Count := Inst_Count - 1; end loop; Diag_End := Index (Diag (Diag_Start .. Diag_Last), ": "); return Result (Result'First .. Res_Idx - 1) & Diag (Diag_Start .. Diag_End) & ' ' & GPS_Prefix & Diag (Diag_End + 1 .. Diag_Last); end; end if; else return Diag; end if; end Add_GPS_Prefix; procedure Counted_Print_Diagnosis (Position : Error_Messages_Storage.Cursor) is begin if not Limit_Exceeded then if Max_Diagnoses > 0 and then 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 (Add_GPS_Prefix (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 Hour_Of_Chech := Integer (Sec_Of_Check) / Seconds_In_Hour; Minute_Of_Check := (Integer (Sec_Of_Check) rem Seconds_In_Hour) / 60; if Text_Report_ON then 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) & ' '); 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 if; if XML_Report_ON then XML_Report_No_EOL ("" & Trim (Year (Time_Of_Check)'Img, Left) & '-', Indent_Level => 1); XML_Report_No_EOL (if Month_Of_Check < 10 then "0" else ""); XML_Report_No_EOL (Trim (Month_Of_Check'Img, Left) & '-'); XML_Report_No_EOL (if Day_Of_Check < 10 then "0" else ""); XML_Report_No_EOL (Trim (Day_Of_Check'Img, Left) & ' '); XML_Report_No_EOL (if Hour_Of_Chech < 10 then "0" else ""); XML_Report_No_EOL (Trim (Hour_Of_Chech'Img, Left) & ':'); XML_Report_No_EOL (if Minute_Of_Check < 10 then "0" else ""); XML_Report (Trim (Minute_Of_Check'Img, Left) & ""); XML_Report ("" & Tool_Name.all & ' ' & Gnat_Version_String & "", Indent_Level => 1); XML_Report_No_EOL ("", Indent_Level => 1); Print_Gnatcheck_Command_Line (XML => True); XML_Report (""); XML_Report_No_EOL ("", Indent_Level => 1); Print_Runtime (XML => True); XML_Report (""); end if; end Print_Report_Header; ------------------- -- Print_Runtime -- ------------------- procedure Print_Runtime (XML : Boolean := False) is begin if ASIS_UL.Compiler_Options.Custom_RTS /= null then if XML then XML_Report (ASIS_UL.Compiler_Options.Custom_RTS.all); else Report (ASIS_UL.Compiler_Options.Custom_RTS.all); end if; else if XML then XML_Report_No_EOL ("default"); else Report (""); end if; end if; end Print_Runtime; ----------------------------- -- Print_Violation_Summary -- ----------------------------- procedure Print_Violation_Summary is begin if Text_Report_ON then 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 if; if XML_Report_ON then XML_Report ("" & Image (Detected_Non_Exempted_Violations) & "", Indent_Level => 1); XML_Report ("" & Image (Detected_Exemption_Warning) & "", Indent_Level => 1); XML_Report ("" & Image (Detected_Compiler_Error) & "", Indent_Level => 1); XML_Report ("" & Image (Detected_Exempted_Violations) & "", Indent_Level => 1); XML_Report (""); end if; 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; First_Par_Idx : Natural; Pars_Start : Natural; pragma Unreferenced (Pars_Start); Pars_End : Natural; Last_Par_Idx : Natural; Has_Param : Boolean := False; Exem_Span : Asis.Text.Span := Nil_Span; SF : constant SF_Id := File_Find (El); Rule : Rule_Id; Exemption_Kind : Exemption_Kinds; Exempted_At : Parametrized_Exemption_Sections.Cursor; -- Used to check if the same rule with the same parameters is already -- exempted - set to No_Element if it is not the case or points to the -- record corresponding to the exemption section that exempts the same -- rule with the same parameters Par : String_Access; use Gnatcheck.Rules.Exemption_Parameters; 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, -- may be, with parameter names, but the latter is allowed only if -- fine-tined exemptions is allowed for the rule, and if parameter -- names make sense for the given 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))); First_Par_Idx := Tmp_Str'First + 1; -- skip '"' Last_Par_Idx := Index (Tmp_Str.all, ":"); if Last_Par_Idx = 0 then Last_Par_Idx := Tmp_Str'Last - 1; -- skip '"' else Last_Par_Idx := Last_Par_Idx - 1; -- skip ':' Has_Param := True; end if; Rule := Get_Rule (Trim (Tmp_Str (First_Par_Idx .. Last_Par_Idx), Both)); else Rule := No_Rule; end if; -- 3.1 Check if we have an existing rule 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); Free (Tmp_Str); return; end if; -- 3.2 Check if we have parameter(s) specified then parameter(s) make(s) -- sense for the rule. if Has_Param then if not Allows_Parametrized_Exemption (Rule) then Store_Diagnosis (Text => Build_GNAT_Location (Next_Arg) & ": rule " & Rule_Name (Rule) & " cannot have parametric " & "exemption, ignored", Diagnosis_Kind => Exemption_Warning, SF => SF); Free (Tmp_Str); return; end if; First_Par_Idx := Last_Par_Idx + 2; Pars_End := Tmp_Str'Last - 1; while First_Par_Idx < Pars_End and then Tmp_Str (First_Par_Idx) = ' ' loop First_Par_Idx := First_Par_Idx + 1; end loop; Set_Rule_Exempt_Pars (Rule, Tmp_Str (First_Par_Idx .. Pars_End), SF, Build_GNAT_Location (Next_Arg)); if Is_Empty (Rule_Exemption_Parameters) then Free (Tmp_Str); return; end if; 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); Free (Tmp_Str); return; end if; if not Has_Param and then Allows_Parametrized_Exemption (Rule) then -- Is Rule already exempted with parameters? if not Parametrized_Exemption_Sections.Is_Empty (Rule_Param_Exempt_Sections (Rule)) then Store_Diagnosis (Text => Build_GNAT_Location (El) & ": rule " & Rule_Name (Rule) & " is already exempted with parameter(s)" & " at line" & Parametrized_Exemption_Sections.Element (Parametrized_Exemption_Sections.First (Rule_Param_Exempt_Sections (Rule))). Exempt_Info.Line_Start'Img, Diagnosis_Kind => Exemption_Warning, SF => SF); Free (Tmp_Str); return; end if; end if; if Has_Param then Is_Exempted_With_Pars (Rule, Exempted_At); if Parametrized_Exemption_Sections.Has_Element (Exempted_At) then Store_Diagnosis (Text => Build_GNAT_Location (El) & ": rule " & Rule_Name (Rule) & " is already exempted with the same parameters" & " at line" & Parametrized_Exemption_Sections.Element (Exempted_At).Exempt_Info.Line_Start'Img, Diagnosis_Kind => Exemption_Warning, SF => SF); Free (Tmp_Str); return; else -- We have to check the following: -- -- Exempt_On, Rule:Par1, Par3 -- ... -- Exempt_On, Rule:Par1, Par2 Same_Parameter_Exempted (Rule, Exempted_At, Par); if Parametrized_Exemption_Sections.Has_Element (Exempted_At) then Store_Diagnosis (Text => Build_GNAT_Location (El) & ": rule " & Rule_Name (Rule) & " is already exempted with parameter '" & Par.all & "' at line" & Parametrized_Exemption_Sections.Element (Exempted_At).Exempt_Info.Line_Start'Img, Diagnosis_Kind => Exemption_Warning, SF => SF); Free (Tmp_Str); Free (Par); return; end if; -- If we are here then we know for sure that the -- parametric exemption is correct, and there is no -- open exemption section for this rule and this -- parameter(s). So we can just add the corresponding record -- to Rule_Param_Exempt_Sections: Parametrized_Exemption_Sections.Insert (Rule_Param_Exempt_Sections (Rule), (Exempt_Info => (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), Rule => Rule, SF => SF, Params => To_Pars_List (Rule_Exemption_Parameters))); end if; else 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); end if; Free (Tmp_Str); when Exempt_Off => if Has_Param then Is_Exempted_With_Pars (Rule, Exempted_At); if not Parametrized_Exemption_Sections.Has_Element (Exempted_At) then Store_Diagnosis (Text => Build_GNAT_Location (El) & ": rule " & Rule_Name (Rule) & " is not in exempted state", Diagnosis_Kind => Exemption_Warning, SF => SF); return; else Turn_Off_Parametrized_Exemption (Rule, Exempted_At, Exem_Span, SF); end if; else 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); end if; 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; Next_Post_Param_Section : Parametrized_Exemption_Sections.Cursor; use Parametrized_Exemption_Sections; Next_Par_S_Info : Parametrized_Exemption_Info; 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; Diag_Column : 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; -- First, check for non-parametric exemptions: 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); end if; -- Check for parametric exemptions if not Is_Exempted and then Allows_Parametrized_Exemption (Diag.Rule) and then not Parametrized_Exemption_Sections.Is_Empty (Postponed_Param_Exempt_Sections (Diag.Rule) (SF)) then Diag_Column := Select_Column (Diag.Text); Diag.Justification := Get_Param_Justification (Rule => Diag.Rule, Diag => Diag.Text.all, SF => SF, Line => Diag_Line, Col => Diag_Column, Check_Postponed_Exemptions => True); end if; if Diag.Justification /= null then Error_Messages_Storage.Replace_Element (Container => All_Error_Messages, Position => Position, New_Item => Diag); end if; end if; end Map_Diagnosis; -- Start of processing for Process_Postponed_Exemptions 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. 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 -- Non-parametric exemptions: 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; -- Parametric exemptions: if Allows_Parametrized_Exemption (Rule) and then not Is_Empty (Postponed_Param_Exempt_Sections (Rule) (SF)) then Next_Post_Param_Section := First (Postponed_Param_Exempt_Sections (Rule) (SF)); while Has_Element (Next_Post_Param_Section) loop Next_Par_S_Info := Parametrized_Exemption_Sections.Element (Next_Post_Param_Section); if Next_Par_S_Info.Exempt_Info.Detected = 0 then Store_Diagnosis (Text => Short_Source_Name (SF) & ':' & Image (Next_Par_S_Info.Exempt_Info.Line_End) & ':' & Image (Next_Par_S_Info.Exempt_Info.Col_End) & ": no detection for '" & Rule_Name (Rule) & ": " & Params_Img (Next_Par_S_Info.Params, Rule) & "' rule in exemption section starting " & "at line" & Next_Par_S_Info.Exempt_Info.Line_Start'Img, Diagnosis_Kind => Exemption_Warning, SF => SF); end if; Next_Post_Param_Section := Next (Next_Post_Param_Section); end loop; end if; end loop; end if; end loop; -- Parametric exemptions: end Process_Postponed_Exemptions; ------------------------- -- Rule_List_File_Name -- ------------------------- function Rule_List_File_Name return String is Dot_Idx : constant Natural := Index (Rule_List_File_Name_Str, ".", Forward); begin if not Aggregated_Project then return Rule_List_File_Name_Str; end if; pragma Assert (Dot_Idx > 0); return Rule_List_File_Name_Str (Rule_List_File_Name_Str'First .. Dot_Idx - 1) & Number.all & Rule_List_File_Name_Str (Dot_Idx .. Rule_List_File_Name_Str'Last); end Rule_List_File_Name; -------------------- -- Rule_Parameter -- -------------------- function Rule_Parameter (Diag : String; Rule : Rule_Id) return String is begin case Rule is when Restrictions_Id => return Restriction_Rule_Parameter (Diag); when Style_Checks_Id => return ""; -- ??? NOT IMPLEMENTED YET!!!!!!! when Warnings_Id => return Warning_Rule_Parameter (Diag); when others => return Rule_Parameter (All_Rules.Table (Rule).all, Diag); end case; end Rule_Parameter; ------------------------------------------------- -- Rule_Parametrized_Exem_Sections_Debug_Image -- ------------------------------------------------- procedure Rule_Parametrized_Exem_Sections_Debug_Image (Rule : Rule_Id) is begin Info ("** PARAMETRIC EXEMPTION SECTIONS FOR RULE" & Rule'Img & " (" & Rule_Name (Rule) & ") **"); if Parametrized_Exemption_Sections.Is_Empty (Rule_Param_Exempt_Sections (Rule)) then Info (" No parametric exemption sections"); else Parametrized_Exemption_Sections.Iterate (Container => Rule_Param_Exempt_Sections (Rule), Process => Parametrized_Exem_Section_Debug_Image'Access); end if; end Rule_Parametrized_Exem_Sections_Debug_Image; ----------------------------- -- Same_Parameter_Exempted -- ----------------------------- procedure Same_Parameter_Exempted (Rule : Rule_Id; Exempted_At : out Parametrized_Exemption_Sections.Cursor; Par : out String_Access) is Next_Par : Exemption_Parameters.Cursor := Exemption_Parameters.First (Rule_Exemption_Parameters); use Parametrized_Exemption_Sections; Next_Section : Cursor; begin Free (Par); Exempted_At := No_Element; if not Is_Empty (Rule_Param_Exempt_Sections (Rule)) then while Exemption_Parameters.Has_Element (Next_Par) loop Next_Section := First (Rule_Param_Exempt_Sections (Rule)); while Has_Element (Next_Section) loop if Belongs (Exemption_Parameters.Element (Next_Par), Parametrized_Exemption_Sections.Element (Next_Section).Params) then Exempted_At := Next_Section; Par := new String'(Exemption_Parameters.Element (Next_Par)); return; end if; Next_Section := Next (Next_Section); end loop; Next_Par := Exemption_Parameters.Next (Next_Par); end loop; end if; end Same_Parameter_Exempted; ------------------- -- Select_Column -- ------------------- function Select_Column (Diag : String_Access) return Positive is Start_Idx : Natural; End_Idx : Natural; begin Start_Idx := Index (Diag.all, ":") + 1; Start_Idx := Index (Diag (Start_Idx .. Diag'Last), ":") + 1; End_Idx := Index (Diag (Start_Idx .. Diag'Last), ":") - 1; return Positive'Value (Diag (Start_Idx .. End_Idx)); end Select_Column; ----------------- -- Select_Line -- ----------------- function Select_Line (Diag : String_Access) return Positive is Start_Idx : Natural; End_Idx : Natural; begin Start_Idx := Index (Diag.all, ":"); if Start_Idx = Diag'First + 1 and then Diag (Start_Idx + 1) = '\' then Start_Idx := Index (Diag (Start_Idx + 2 .. Diag'Last), ":"); end if; Start_Idx := Start_Idx + 1; End_Idx := Index (Diag (Start_Idx .. Diag'Last), ":") - 1; return Positive'Value (Diag (Start_Idx .. End_Idx)); end Select_Line; -------------------------- -- Set_Rule_Exempt_Pars -- -------------------------- procedure Set_Rule_Exempt_Pars (Rule : Rule_Id; Pars : String; SF : SF_Id; SLOC : String) is use Gnatcheck.Rules.Exemption_Parameters; Par_Start : Natural := Pars'First; Par_End : Natural; Last_Idx : constant Natural := Pars'Last; Position : Cursor; Success : Boolean; Warning_Par : constant Boolean := Rule = Warnings_Id; -- In case of Warnings rule, we consider parameters one by one. That is, -- for "ad.c.d.fg" as Pars string we separately store 'a', 'd', '.c', -- '.d', '.f' and 'g' begin Clear (Rule_Exemption_Parameters); loop while Par_Start <= Last_Idx and then Pars (Par_Start) = ' ' loop Par_Start := Par_Start + 1; end loop; exit when Par_Start > Last_Idx; if Warning_Par then Par_End := (if Pars (Par_Start) = '.' then Par_Start + 1 else Par_Start); else Par_End := Index (Pars (Par_Start + 1 .. Last_Idx), (1 => ',')); end if; if Par_End = 0 then Par_End := Last_Idx; elsif not Warning_Par then Par_End := Par_End - 1; end if; while Pars (Par_End) = ' ' loop Par_End := Par_End - 1; end loop; if Allowed_As_Exemption_Parameter (Rule, (if Rule = Warnings_Id then Remove_Spaces (Pars (Par_Start .. Par_End)) else To_Lower (Remove_Spaces (Pars (Par_Start .. Par_End))))) then Insert (Container => Rule_Exemption_Parameters, New_Item => (if Rule = Warnings_Id then Remove_Spaces (Pars (Par_Start .. Par_End)) else To_Lower (Remove_Spaces (Pars (Par_Start .. Par_End)))), Position => Position, Inserted => Success); if not Success then Store_Diagnosis (Text => SLOC & ": parameter " & Pars (Par_Start .. Par_End) & " duplicated in rule exemption", Diagnosis_Kind => Exemption_Warning, SF => SF); end if; else Store_Diagnosis (Text => SLOC & ": parameter " & Pars (Par_Start .. Par_End) & " is not allowed in exemption for rule " & Rule_Name (Rule), Diagnosis_Kind => Exemption_Warning, SF => SF); Clear (Rule_Exemption_Parameters); end if; if Warning_Par then Par_Start := Par_Start + 1; exit when Par_Start > Last_Idx; else Par_Start := Index (Pars (Par_End + 1 .. Last_Idx), ","); if Par_Start = 0 then exit; else Par_Start := Par_Start + 1; end if; end if; end loop; end Set_Rule_Exempt_Pars; --------------------- -- Store_Diagnosis -- --------------------- procedure Store_Diagnosis (Text : String; Diagnosis_Kind : Diagnosis_Kinds; SF : SF_Id; Rule : Rule_Id := No_Rule; Justification : String_Access := null) is Tmp : Diag_Message := (Text => new String'(Text), Justification => Justification, Diagnosis_Kind => Diagnosis_Kind, Rule => Rule, SF => SF, Num => Next_Message_Num); use Parametrized_Exemption_Sections; begin -- We need this check to avoid diagnoses duplication. Our set container -- has broken "<" relation, so Insert may add diagnoses that are already -- stored in the container (see the documentation for "<" for more -- details. if not Error_Messages_Storage.Contains (Container => All_Error_Messages, Item => Tmp) then if Justification /= null then -- Here we count detections for non-parametric exemption -- sections only Exemption_Sections (Rule).Detected := Exemption_Sections (Rule).Detected + 1; end if; if Rule /= No_Rule -- To skip compiler errors and exemption warnings and then Justification = null and then Allows_Parametrized_Exemption (Rule) and then not Needs_Postponed_Exemption_Processing (Rule) and then not Is_Empty (Rule_Param_Exempt_Sections (Rule)) then Tmp.Justification := Get_Param_Justification (Rule, Text, SF, Check_Postponed_Exemptions => False); -- This call counts detections for parametric exemption sections end if; Error_Messages_Storage.Insert (Container => All_Error_Messages, New_Item => Tmp, Position => Unused_Position, Inserted => Unused_Inserted); else Free (Tmp.Text); 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; ------------------ -- To_Pars_List -- ------------------ function To_Pars_List (Pars : Exemption_Parameters.Set) return String_List_Access is use Exemption_Parameters; Result : constant String_List_Access := new String_List (1 .. Natural (Length (Pars))); Next_Par : Cursor := First (Pars); begin for J in Result'Range loop Result (J) := new String'(Exemption_Parameters.Element (Next_Par)); Next_Par := Next (Next_Par); end loop; return Result; end To_Pars_List; --------------------------- -- Source_List_File_Name -- --------------------------- function Source_List_File_Name return String is Dot_Idx : constant Natural := Index (Source_List_File_Name_Str, ".", Forward); begin if not Aggregated_Project then return Source_List_File_Name_Str; end if; pragma Assert (Dot_Idx > 0); return Source_List_File_Name_Str (Source_List_File_Name_Str'First .. Dot_Idx - 1) & Number.all & Source_List_File_Name_Str (Dot_Idx .. Source_List_File_Name_Str'Last); end Source_List_File_Name; ------------------------ -- 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; ------------------------------------- -- Turn_Off_Parametrized_Exemption -- ------------------------------------- procedure Turn_Off_Parametrized_Exemption (Rule : Rule_Id; Exempted_At : in out Parametrized_Exemption_Sections.Cursor; Closing_Span : Asis.Text.Span; SF : SF_Id) is Tmp : String_Access; New_Section : Parametrized_Exemption_Info; begin if Needs_Postponed_Exemption_Processing (Rule) then New_Section := Parametrized_Exemption_Sections.Element (Exempted_At); New_Section.Exempt_Info.Line_End := Closing_Span.Last_Line; New_Section.Exempt_Info.Col_End := Closing_Span.Last_Column; Parametrized_Exemption_Sections.Insert (Container => Postponed_Param_Exempt_Sections (Rule) (SF), New_Item => New_Section); null; -- !!!NOT IMPLEMENTED YET!!! @@ ??? else if Parametrized_Exemption_Sections.Element (Exempted_At).Exempt_Info.Detected = 0 then -- No one needs Justification Tmp := Parametrized_Exemption_Sections.Element (Exempted_At).Exempt_Info.Justification; Free (Tmp); -- ??? -- Does it really free the memory? Store_Diagnosis (Text => Short_Source_Name (SF) & ':' & Image (Closing_Span.Last_Line) & ':' & Image (Closing_Span.Last_Column) & ": no detection for '" & Rule_Name (Rule) & ": " & Params_Img (Parametrized_Exemption_Sections.Element (Exempted_At).Params, Rule) & "' rule in exemption section starting at line" & Parametrized_Exemption_Sections.Element (Exempted_At).Exempt_Info.Line_Start'Img, Diagnosis_Kind => Exemption_Warning, SF => SF); end if; end if; Parametrized_Exemption_Sections.Delete (Rule_Param_Exempt_Sections (Rule), Exempted_At); end Turn_Off_Parametrized_Exemption; -------------------------- -- XML_Report_Diagnosis -- -------------------------- procedure XML_Report_Diagnosis (Diag : Diag_Message; Short_Report : Boolean) is Indentation : constant Natural := (if Short_Report then 1 else 2); Exempted : constant Boolean := Diag.Diagnosis_Kind = Rule_Violation and then Diag.Justification /= null; Message : constant String := Diag.Text.all; L_Idx : Natural := Message'First; R_Idx : Natural := Index (Message, ":"); Last_Idx : constant Natural := Message'Last; begin XML_Report_No_EOL ((if Diag.Diagnosis_Kind = Exemption_Warning then " Indentation); XML_Report_No_EOL (" file=" & """" & Message (L_Idx .. R_Idx - 1) & """ "); L_Idx := R_Idx + 1; R_Idx := Index (Message (L_Idx .. Last_Idx), ":"); XML_Report_No_EOL ("line=" & """" & Message (L_Idx .. R_Idx - 1) & """ "); L_Idx := R_Idx + 1; R_Idx := Index (Message (L_Idx .. Last_Idx), ":"); while Message (L_Idx) = '0' loop L_Idx := L_Idx + 1; end loop; XML_Report_No_EOL ("column=" & """" & Message (L_Idx .. R_Idx - 1) & """"); if Diag.Diagnosis_Kind = Rule_Violation then XML_Report_No_EOL (" rule-id=""" & Rule_Name (Diag.Rule) & '"'); end if; XML_Report (">"); XML_Report ("" & Message (R_Idx + 2 .. Last_Idx) & "", Indent_Level => Indentation + 1); if Exempted then XML_Report ("" & Diag.Justification.all & "", Indent_Level => Indentation + 1); end if; XML_Report ((if Diag.Diagnosis_Kind = Exemption_Warning then "" elsif Diag.Diagnosis_Kind = Compiler_Error then "" elsif Exempted then "" else ""), Indent_Level => Indentation); end XML_Report_Diagnosis; end Gnatcheck.Diagnoses;