------------------------------------------------------------------------------ -- -- -- GNATCHECK COMPONENTS -- -- -- -- G N A T C H E C K . R U L E S . C U S T O M _ 1 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2019, 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.Characters.Handling; use Ada.Characters.Handling; with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Wide_Fixed; use Ada.Strings.Wide_Fixed; with Ada.Text_IO; use Ada.Text_IO; with Ada.Wide_Characters.Unicode; with Asis.Clauses; use Asis.Clauses; with Asis.Compilation_Units; use Asis.Compilation_Units; with Asis.Declarations; use Asis.Declarations; with Asis.Definitions; use Asis.Definitions; with Asis.Elements; use Asis.Elements; with Asis.Expressions; use Asis.Expressions; with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds; with Asis.Extensions; use Asis.Extensions; with Asis.Iterator; with Asis.Statements; use Asis.Statements; with Asis.Text; use Asis.Text; with Namet; with Snames; with GNAT.Table; with ASIS_UL.Misc; use ASIS_UL.Misc; with ASIS_UL.Output; use ASIS_UL.Output; with ASIS_UL.Utilities; use ASIS_UL.Utilities; with Gnatcheck.ASIS_Utilities; use Gnatcheck.ASIS_Utilities; with Gnatcheck.Traversal_Stack; use Gnatcheck.Traversal_Stack; package body Gnatcheck.Rules.Custom_1 is ------------------------------------- -- General-purpose local functions -- ------------------------------------- ------------------------------------- -- Rule parameter parsing routines -- ------------------------------------- procedure Parse_Par (First_Par_Id : out Natural; Last_Par_Id : out Positive; First_Str_Id : out Natural; Last_Str_Id : out Positive; Par_String : String); -- This function parses its Par_String parameter that is supposed to be a -- slice of the rule parameter obtained by -- Gnatcheck.Rules.Rule_Table.Process_Rule_Option (see also the -- documentation of Process_Rule_Parameter for Rule_Template type in -- Gnatcheck.Rules). If Par_String contains a '=' character, it sets -- First_Par_Id and Last_Par_Id to point to the part of Par_String that -- precedes the (leftmost) '=' character (cutting out the leading and -- trailing white spaces if any), and First_Str_Id and Last_Str_Id are -- set to point to the part of Par_String that follows the (leftmost) '=' -- character (cutting out the leading and trailing white spaces if any). -- If Par_String does not contain a '=' character, First_Str_Id is set to -- 0 (Last_Str_Id is undefined), and First_Par_Id and Last_Par_Id point to -- the leftmost and rightmost non-blank characters of Par_String. If -- Par_String does not contain any non-blank character, First_Par_Id and -- First_Str_Id are set to 0, Last_Par_Id and Last_Str_Id are indefinite. -- If Par_String has '=' as it first (non-blank) character (most probably -- this means a bug in the parameter structure), First_Par_Id is set to 0, -- Last_Par_Id is indefinite, Last_Str_Id and Par_String are set to point -- to (non-blank) part of Par_String after '='. ------------------------------------- -- Rule-specific local subprograms -- ------------------------------------- function Is_Access_Suffix (S : String) return Boolean; -- For Identifier_Suffixes rule. -- S is supposed to be the 'string' part from the +R parameter option, and -- it is known that Is_Identifier_Suffix (S) = False. The function checks -- if S has the structure Suffix1 (Suffix2), where -- Is_Identifier_Suffix (Suffix1) AND Is_Identifier_Suffix (Suffix2) = True function Is_Access_To_Access (Def : Asis.Element; Arg : Asis.Element) return Boolean; function Is_Access_To_Class (Def : Asis.Element) return Boolean; -- For Identifier_Prefixes and Identifier_Suffixes rules. -- Def is supposed to be of An_Access_Type_Definition kind. Checks if it -- defines an access to access type/access to class-wide type. -- In case of checking for access-to-access type we need a second argument -- to represent the place of the check. Consider: -- -- package Pack1 is -- type PT1 is private; -- ... -- end Pack1; -- -- package Pack2 is -- type PT2 is private; -- private -- type PT2 is access Integer; -- -- type A1 is access Pack1.PT1; -- type A2 is access PT2; -- -- A1 is not access-to-access, but A2 is, because at the place where A2 is -- defined the full view of PT2 is visible and PT2 is an access type but -- not a private type. ----------------------------------------------- -- Bodies of general-purpose local functions -- ----------------------------------------------- --------------- -- Parse_Par -- --------------- procedure Parse_Par (First_Par_Id : out Natural; Last_Par_Id : out Positive; First_Str_Id : out Natural; Last_Str_Id : out Positive; Par_String : String) is Eq_Pos : Natural := 0; Tmp : Natural; begin for J in Par_String'Range loop if Par_String (J) = '=' then Eq_Pos := J; exit; end if; end loop; if Eq_Pos = 0 then Tmp := Par_String'Last; else Tmp := Eq_Pos - 1; end if; First_Par_Id := 0; for J in Par_String'First .. Tmp loop if not Is_White_Space (Par_String (J)) then First_Par_Id := J; exit; end if; end loop; if First_Par_Id > 0 then for J in reverse First_Par_Id .. Tmp loop if not Is_White_Space (Par_String (J)) then Last_Par_Id := J; exit; end if; end loop; end if; First_Str_Id := 0; if Eq_Pos > 0 then for J in Eq_Pos + 1 .. Par_String'Last loop if not Is_White_Space (Par_String (J)) then First_Str_Id := J; exit; end if; end loop; if First_Str_Id > 0 then for J in reverse First_Str_Id .. Par_String'Last loop if not Is_White_Space (Par_String (J)) then Last_Str_Id := J; exit; end if; end loop; end if; end if; end Parse_Par; ----------------------------------------------- -- Bodies of rule-specific local subprograms -- ----------------------------------------------- ------------------------- -- Is_Access_To_Access -- ------------------------- function Is_Access_To_Access (Def : Asis.Element; Arg : Asis.Element) return Boolean is Tmp, Tmp1 : Asis.Element; Result : Boolean := False; begin if Access_Type_Kind (Def) in A_Pool_Specific_Access_To_Variable .. An_Access_To_Constant then Tmp := Asis.Definitions.Access_To_Object_Definition (Def); Tmp := Asis.Definitions.Subtype_Mark (Tmp); Tmp := Normalize_Reference (Tmp); Tmp := Corresponding_Name_Declaration (Tmp); if Declaration_Kind (Tmp) in An_Incomplete_Type_Declaration .. A_Tagged_Incomplete_Type_Declaration then Tmp1 := Corresponding_Type_Completion (Tmp); if not Is_Nil (Tmp1) and then Is_Equal (Enclosing_Compilation_Unit (Tmp), Enclosing_Compilation_Unit (Tmp1)) then -- For this check, we consider the full declaration instead of -- incomplete type declaration only if both of them are in the -- same unit. Tmp := Tmp1; end if; else Tmp := Corresponding_First_Subtype (Tmp); end if; if Declaration_Kind (Tmp) = A_Private_Type_Declaration and then Full_View_Visible (Tmp, At_Place => Arg) then Tmp := Corresponding_Type_Completion (Tmp); end if; Tmp := First_Name (Tmp); Result := Denotes_Access_Subtype (Tmp); end if; return Result; end Is_Access_To_Access; ------------------------ -- Is_Access_To_Class -- ------------------------ function Is_Access_To_Class (Def : Asis.Element) return Boolean is Tmp : Asis.Element; Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Def); Result : Boolean := False; begin if Arg_Kind = A_Pool_Specific_Access_To_Variable or else Arg_Kind = An_Access_To_Variable or else Arg_Kind = An_Access_To_Constant or else Arg_Kind = A_Formal_Pool_Specific_Access_To_Variable or else Arg_Kind = A_Formal_Access_To_Variable or else Arg_Kind = A_Formal_Access_To_Constant then Tmp := Asis.Definitions.Access_To_Object_Definition (Def); Tmp := Asis.Definitions.Subtype_Mark (Tmp); if Attribute_Kind (Tmp) = A_Class_Attribute then Result := True; else if Expression_Kind (Tmp) = An_Identifier or else Expression_Kind (Tmp) = A_Selected_Component then Result := Denotes_Class_Wide_Subtype (Tmp); end if; end if; end if; return Result; end Is_Access_To_Class; ---------------------- -- Is_Access_Suffix -- ---------------------- function Is_Access_Suffix (S : String) return Boolean is Parameter : constant String := Trim (S, Both); First_Idx : constant Natural := Parameter'First; Last_Idx : constant Natural := Parameter'Last - 1; Bracket_Idx : Natural; Result : Boolean := False; begin if Parameter (Last_Idx + 1) = ')' then Bracket_Idx := Index (Parameter, "("); if Bracket_Idx > 0 then if Is_Identifier_Suffix (To_Wide_String (Trim (Parameter (First_Idx .. Bracket_Idx - 1), Right))) then Result := Is_Identifier_Suffix (To_Wide_String (Trim (Parameter (Bracket_Idx + 1 .. Last_Idx), Left))); end if; end if; end if; return Result; end Is_Access_Suffix; -------------------------------------------- -- Bodies of rule implementation routines -- -------------------------------------------- ---------------------- -- Anonymous_Arrays -- ---------------------- ---------------------------------- -- Init_Rule (Anonymous_Arrays) -- ---------------------------------- procedure Init_Rule (Rule : in out Anonymous_Arrays_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Anonymous_Arrays"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("anonymous array types"); Rule.Diagnosis := new String'("anonymous array type"); end Init_Rule; ------------------------------------------ -- Rule_Check_Pre_Op (Anonymous_Arrays) -- ------------------------------------------ procedure Rule_Check_Pre_Op (Rule : in out Anonymous_Arrays_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); begin if Type_Kind (Element) in An_Unconstrained_Array_Definition .. A_Constrained_Array_Definition and then Declaration_Kind (Get_Enclosing_Element) in A_Variable_Declaration .. A_Constant_Declaration then State.Detected := True; end if; end Rule_Check_Pre_Op; ------------------------------------------- -- Enumeration_Ranges_In_CASE_Statements -- ------------------------------------------- ------------------------------------------------------- -- Init_Rule (Enumeration_Ranges_In_CASE_Statements) -- ------------------------------------------------------- procedure Init_Rule (Rule : in out Enumeration_Ranges_In_CASE_Statements_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Enumeration_Ranges_In_CASE_Statements"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("enumeration ranges as choices in case " & "statements"); Rule.Diagnosis := new String'("enumeration range as a choice in a " & "case statement"); end Init_Rule; --------------------------------------------------------------- -- Rule_Check_Pre_Op (Enumeration_Ranges_In_CASE_Statements) -- --------------------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Enumeration_Ranges_In_CASE_Statements_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Case_Var : Asis.Element; begin if Definition_Kind (Element) = A_Discrete_Range and then Path_Kind (Get_Enclosing_Element) = A_Case_Path then Case_Var := Case_Expression (Get_Enclosing_Element (Steps_Up => 1)); if Has_Enumeration_Type (Case_Var) then State.Detected := True; end if; end if; end Rule_Check_Pre_Op; -------------------------------- -- Exceptions_As_Control_Flow -- -------------------------------- -------------------------------------------- -- Init_Rule (Exceptions_As_Control_Flow) -- -------------------------------------------- procedure Init_Rule (Rule : in out Exceptions_As_Control_Flow_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Exceptions_As_Control_Flow"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("exceptions for control flow"); Rule.Diagnosis := new String'("this exception will be handled in " & "the same body, line%1%"); end Init_Rule; ---------------------------------------------------- -- Rule_Check_Pre_Op (Exceptions_As_Control_Flow) -- ---------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Exceptions_As_Control_Flow_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Raised_Exc : Asis.Element; Encl_Body : Asis.Element; Next_Frame : Asis.Element := Nil_Element; -- Construct that can contain exception handlers Step_Up : Elmt_Idx := 0; begin if Statement_Kind (Element) = A_Raise_Statement then Raised_Exc := Raised_Exception (Element); if not Is_Nil (Raised_Exc) then -- First, get the enclosing body: Encl_Body := Get_Enclosing_Element (Step_Up); while Element_Kind (Encl_Body) in A_Statement .. A_Path loop Step_Up := Step_Up + 1; Encl_Body := Get_Enclosing_Element (Step_Up); end loop; if Declaration_Kind (Encl_Body) not in A_Procedure_Body_Declaration .. A_Function_Body_Declaration then return; end if; Raised_Exc := Get_Name_Definition (Raised_Exc); Step_Up := 0; Next_Frame := Get_Enclosing_Element (Step_Up); Check_Frames : loop -- Computing the next frame while not Is_Frame (Next_Frame) loop Step_Up := Step_Up + 1; Next_Frame := Get_Enclosing_Element (Step_Up); end loop; -- Processing the next frame declare Handlers : constant Asis.Element_List := Get_Handlers (Next_Frame); Handler : Asis.Element := Nil_Element; Handled_Exc : Asis.Element; begin if Handlers'Length = 0 then return; end if; Check_Handlers : for J in Handlers'Range loop declare Exc_Choices : constant Asis.Element_List := Exception_Choices (Handlers (J)); begin for K in Exc_Choices'Range loop if Definition_Kind (Exc_Choices (K)) = An_Others_Choice then State.Detected := True; else Handled_Exc := Get_Name_Definition (Exc_Choices (K)); State.Detected := Is_Equal (Raised_Exc, Handled_Exc); end if; if State.Detected then Handler := Handlers (J); State.Diag_Params := Enter_String ("%1%" & Element_Span (Handler).First_Line'Img); exit Check_Frames; end if; end loop; end; end loop Check_Handlers; end; exit Check_Frames when Is_Equal (Next_Frame, Encl_Body); -- Go to the next frame Step_Up := Step_Up + 1; Next_Frame := Get_Enclosing_Element (Step_Up); end loop Check_Frames; end if; end if; end Rule_Check_Pre_Op; --------------------------------------- -- EXIT_Statements_With_No_Loop_Name -- --------------------------------------- --------------------------------------------------- -- Init_Rule (EXIT_Statements_With_No_Loop_Name) -- --------------------------------------------------- procedure Init_Rule (Rule : in out EXIT_Statements_With_No_Loop_Name_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("EXIT_Statements_With_No_Loop_Name"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("exit statements with no loop name"); Rule.Diagnosis := new String'("exit statement with no loop name"); end Init_Rule; --------------------------------------------------- -- Init_Rule (EXIT_Statements_With_No_Loop_Name) -- --------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out EXIT_Statements_With_No_Loop_Name_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); begin if Statement_Kind (Element) = An_Exit_Statement and then Is_Nil (Exit_Loop_Name (Element)) then State.Detected := True; end if; end Rule_Check_Pre_Op; ----------------------------------- -- Explicit_Full_Discrete_Ranges -- ----------------------------------- ------------------------------------------------ -- Init_Rule (Explicit_Full_Discrete_Ranges) -- ------------------------------------------------ procedure Init_Rule (Rule : in out Explicit_Full_Discrete_Ranges_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Explicit_Full_Discrete_Ranges"); Rule.Synonym := new String'("Explicit_Discrete_Ranges"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("explicit discrete ranges"); Rule.Diagnosis := new String'("#1#bad discrete range, consider replacement " & "with subtype mark" & "#2#bad discrete range, consider replacement " & "with 'Range attribute"); end Init_Rule; -------------------------------------------------------- -- Rule_Check_Pre_Op (Explicit_Full_Discrete_Ranges) -- -------------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Explicit_Full_Discrete_Ranges_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); L, R : Asis.Element; begin if Discrete_Range_Kind (Element) = A_Discrete_Simple_Expression_Range then L := Lower_Bound (Element); if Attribute_Kind (L) = A_First_Attribute then R := Upper_Bound (Element); if Attribute_Kind (R) = A_Last_Attribute then -- The argument discrete range is to be detected only if -- L and R are or ends with the same identifier L := Prefix (L); R := Prefix (R); if Expression_Kind (L) = A_Selected_Component then L := Selector (L); end if; if Expression_Kind (R) = A_Selected_Component then L := Selector (R); end if; if Expression_Kind (L) = An_Identifier and then Expression_Kind (R) = An_Identifier and then To_Lower (To_String (Name_Image (L))) = To_Lower (To_String (Name_Image (R))) then -- Now we have to check that L (and, therefore R) is -- either a subtype mark of a discrete (sub)type or a -- reference to an array data object L := Corresponding_Name_Declaration (L); case Declaration_Kind (L) is when An_Ordinary_Type_Declaration | A_Subtype_Declaration => -- It must be a discrete (sub)type! State.Detected := True; State.Diagnosis := 1; when A_Variable_Declaration | A_Constant_Declaration | A_Component_Declaration | A_Parameter_Specification | A_Return_Variable_Specification | A_Return_Constant_Specification | An_Object_Renaming_Declaration | A_Formal_Object_Declaration => -- It must be a declaration of an array object or an -- access object that points to an array object! State.Detected := True; State.Diagnosis := 2; when others => null; end case; end if; end if; end if; end if; end Rule_Check_Pre_Op; -------------------------- -- Forbidden_Attributes -- -------------------------- -------------------------------------------------------- -- Data structures and local subprograms for the rule -- -------------------------------------------------------- type Check_Status is (Off, On, Selective); -- The values of this type say if a given attribute/pragma should be -- detected. The Selective value is used only for -- An_Implementation_Defined_Attribute/An_Implementation_Defined_Pragma -- kinds, it means that only some of the GNAT-specific attributes/pragmas -- should be detected. Attribute_Check_Switch : array (Asis.Attribute_Kinds'(An_Access_Attribute) .. Asis.Attribute_Kinds'(An_Unknown_Attribute)) of Check_Status := (others => Off); -- Specifies which pragmas should be detected. GNAT_Attribute_Check_Switch : array (Snames.Attribute_Id) of Boolean := (others => False); -- Specifies which GNAT-specific attributes should be detected. Note, that -- the index range covers all the attribute IDs, both standard and -- GNAT-specific, but only those components that correspond to -- GNAT-specific attributes are referenced function Get_Attribute_Kind (S : String) return Attribute_Kinds; -- Tries to get from its argument (that is treated as an (an identifier -- from) attribute designator and is supposed to be obtained from the rule -- parameter) the corresponding ASIS Attribute_Kinds value. If S does not -- have a structure of an identifier, returns Not_An_Attribute procedure Get_GNAT_Attribute_Id (S : String; Id : out Snames.Attribute_Id; Success : out Boolean); -- Supposing that S is a name of a GNAT attribute, computes its -- Attribute_Id. Sets Success OFF if the argument is not a name of a -- GNAT-specific attribute, otherwise Success is set ON. -------------------------------------------------- -- Activate_In_Test_Mode (Forbidden_Attributes) -- -------------------------------------------------- overriding procedure Activate_In_Test_Mode (Rule : in out Forbidden_Attributes_Rule_Type) is begin Process_Rule_Parameter (Rule => Rule, Param => "Range", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Access", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Img", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Object_Size", Enable => True, Defined_At => ""); end Activate_In_Test_Mode; ----------------------------------------------------------- -- Allowed_As_Exemption_Parameter (Forbidden_Attributes) -- ----------------------------------------------------------- overriding function Allowed_As_Exemption_Parameter (Rule : Forbidden_Attributes_Rule_Type; Parameter : String) return Boolean is pragma Unreferenced (Rule); begin return Get_Attribute_Kind (Parameter) in Attribute_Kinds'Succ (Not_An_Attribute) .. An_Implementation_Defined_Attribute; end Allowed_As_Exemption_Parameter; -------------------------------------------------- -- Get_GNAT_Attribute_Id (Forbidden_Attributes) -- -------------------------------------------------- procedure Get_GNAT_Attribute_Id (S : String; Id : out Snames.Attribute_Id; Success : out Boolean) is use Namet; Attribute_Name_Id : Namet.Name_Id; begin if Is_Identifier (To_Wide_String (S)) then Name_Len := S'Length; Name_Buffer (1 .. Name_Len) := To_Lower (S); Attribute_Name_Id := Name_Find; if Attribute_Name_Id in Snames.First_Attribute_Name .. Snames.Last_Attribute_Name then Id := Snames.Get_Attribute_Id (Attribute_Name_Id); Success := True; else Success := False; end if; end if; end Get_GNAT_Attribute_Id; ----------------------------------------------- -- Get_Attribute_Kind (Forbidden_Attributes) -- ----------------------------------------------- function Get_Attribute_Kind (S : String) return Attribute_Kinds is Result : Attribute_Kinds := Not_An_Attribute; Attr_Id : Snames.Attribute_Id; pragma Warnings (Off, Attr_Id); -- We need Attr_Id only as a placeholder in the call to -- Get_GNAT_Attribute_Id Success : Boolean; begin if Is_Identifier (To_Wide_String (S)) then begin case To_Lower (S (S'First)) is when 'a' | 'e' | 'i' | 'o' | 'u' => Result := Attribute_Kinds'Value ("an_" & S & "_attribute"); when others => Result := Attribute_Kinds'Value ("a_" & S & "_attribute"); end case; exception when Constraint_Error => Result := An_Unknown_Attribute; end; end if; if Result = An_Unknown_Attribute then -- We can have a GNAT-specific pragma here! Get_GNAT_Attribute_Id (S, Attr_Id, Success); if Success then Result := An_Implementation_Defined_Attribute; end if; end if; return Result; end Get_Attribute_Kind; -------------------------------------- -- Init_Rule (Forbidden_Attributes) -- -------------------------------------- procedure Init_Rule (Rule : in out Forbidden_Attributes_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Forbidden_Attributes"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("usage of specified attributes"); Rule.Diagnosis := new String'("use of attribute %1%"); end Init_Rule; --------------------------------------- -- Print_Rule (Forbidden_Attributes) -- --------------------------------------- procedure Print_Rule (Rule : Forbidden_Attributes_Rule_Type; Indent_Level : Natural := 0) is All_On : Boolean := True; First_Param : Boolean := True; Rule_Name_Pad : constant String (1 .. Rule_Name (Rule)'Length + 2) := (others => ' '); begin Print_Rule (Rule_Template (Rule), Indent_Level); -- Special case: all attributes are ON for J in Asis.Attribute_Kinds'(An_Access_Attribute) .. Asis.Attribute_Kinds'(An_Implementation_Defined_Attribute) loop if Attribute_Check_Switch (J) /= On then All_On := False; exit; end if; end loop; if All_On then Report_No_EOL (": ALL"); return; end if; -- Standard Ada attributes for J in Asis.Attribute_Kinds'(An_Access_Attribute) .. Asis.Attribute_Kinds'(A_Wide_Wide_Width_Attribute) loop if Attribute_Check_Switch (J) = On then if First_Param then Report_No_EOL (": " & Ada_Attribute_Designator (J)); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Pad & Ada_Attribute_Designator (J), Indent_Level); end if; end if; end loop; case Attribute_Check_Switch (An_Implementation_Defined_Attribute) is when Off => null; when On => if First_Param then Report_No_EOL (": GNAT"); else Report (","); Report_No_EOL (Rule_Name_Pad & "GNAT", Indent_Level); end if; when Selective => for J in GNAT_Attribute_Check_Switch'Range loop if GNAT_Attribute_Check_Switch (J) then if First_Param then Report_No_EOL (": " & GNAT_Attribute_Designator (J)); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Pad & GNAT_Attribute_Designator (J), Indent_Level); end if; end if; end loop; end case; end Print_Rule; ----------------------------------------------- -- Print_Rule_To_File (Forbidden_Attributes) -- ----------------------------------------------- overriding procedure Print_Rule_To_File (Rule : Forbidden_Attributes_Rule_Type; Rule_File : File_Type; Indent_Level : Natural := 0) is All_On : Boolean := True; First_Param : Boolean := True; Rule_Name_Pad : constant String (1 .. Rule_Name (Rule)'Length + 2) := (others => ' '); begin Print_Rule_To_File (Rule_Template (Rule), Rule_File, Indent_Level); -- Special case: all attributes are ON for J in Asis.Attribute_Kinds'(An_Access_Attribute) .. Asis.Attribute_Kinds'(An_Implementation_Defined_Attribute) loop if Attribute_Check_Switch (J) /= On then All_On := False; exit; end if; end loop; if All_On then Report_No_EOL (": ALL"); return; end if; -- Standard Ada attributes for J in Asis.Attribute_Kinds'(An_Access_Attribute) .. Asis.Attribute_Kinds'(A_Wide_Wide_Width_Attribute) loop if Attribute_Check_Switch (J) = On then if First_Param then Put (Rule_File, ": " & Ada_Attribute_Designator (J)); First_Param := False; else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Pad & Ada_Attribute_Designator (J)); end if; end if; end loop; case Attribute_Check_Switch (An_Implementation_Defined_Attribute) is when Off => null; when On => if First_Param then Put (Rule_File, ": GNAT"); else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Pad & "GNAT"); end if; when Selective => for J in GNAT_Attribute_Check_Switch'Range loop if GNAT_Attribute_Check_Switch (J) then if First_Param then Put (Rule_File, ": " & GNAT_Attribute_Designator (J)); First_Param := False; else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Pad & GNAT_Attribute_Designator (J)); end if; end if; end loop; end case; end Print_Rule_To_File; --------------------------------------------------- -- Process_Rule_Parameter (Forbidden_Attributes) -- --------------------------------------------------- procedure Process_Rule_Parameter (Rule : in out Forbidden_Attributes_Rule_Type; Param : String; Enable : Boolean; Defined_At : String) is pragma Unreferenced (Defined_At); Arg_Kind : Attribute_Kinds; GNAT_Attribute : Snames.Attribute_Id; Success : Boolean; begin if Param = "" then if Enable then Rule.Rule_State := Enabled; else Rule.Rule_State := Disabled; end if; return; end if; if To_Lower (Param) = "gnat" then if Enable then Attribute_Check_Switch (An_Implementation_Defined_Attribute) := On; GNAT_Attribute_Check_Switch := (others => True); Rule.Rule_State := Enabled; else Attribute_Check_Switch (An_Implementation_Defined_Attribute) := Off; end if; return; end if; if To_Lower (Param) = "all" then if Enable then Attribute_Check_Switch := (others => On); GNAT_Attribute_Check_Switch := (others => True); Rule.Rule_State := Enabled; -- Attribute_Check_Switch (An_Implementation_Defined_Attribute) := -- Selective; else Attribute_Check_Switch := (others => Off); GNAT_Attribute_Check_Switch := (others => False); Rule.Rule_State := Disabled; end if; return; end if; Arg_Kind := Get_Attribute_Kind (Param); case Arg_Kind is when Not_An_Attribute => Error ("(" & Rule.Name.all & ") wrong attribute designator : " & Param); when An_Implementation_Defined_Attribute => Get_GNAT_Attribute_Id (Param, GNAT_Attribute, Success); if Enable then if Attribute_Check_Switch (Arg_Kind) = Off then Attribute_Check_Switch (Arg_Kind) := Selective; end if; if Success then GNAT_Attribute_Check_Switch (GNAT_Attribute) := True; end if; Rule.Rule_State := Enabled; else GNAT_Attribute_Check_Switch (GNAT_Attribute) := False; if Attribute_Check_Switch (Arg_Kind) = On then Attribute_Check_Switch (Arg_Kind) := Selective; end if; end if; when others => -- Only specific attribute kinds and An_Unknown_Attribute are -- possible if Enable then Attribute_Check_Switch (Arg_Kind) := On; Rule.Rule_State := Enabled; else Attribute_Check_Switch (Arg_Kind) := Off; end if; end case; end Process_Rule_Parameter; ---------------------------------------------- -- Rule_Check_Pre_Op (Forbidden_Attributes) -- ---------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Forbidden_Attributes_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is El_Kind : constant Attribute_Kinds := Attribute_Kind (Element); pragma Unreferenced (Control); pragma Unreferenced (Rule); begin if Expression_Kind (Element) = An_Attribute_Reference then if Attribute_Check_Switch (El_Kind) = On then State.Detected := True; elsif Attribute_Check_Switch (El_Kind) = Selective then declare Attr_Designator : constant String := To_String (Name_Image (Attribute_Designator_Identifier (Element))); Attr_Id : Snames.Attribute_Id; Success : Boolean; begin Get_GNAT_Attribute_Id (Attr_Designator, Attr_Id, Success); State.Detected := GNAT_Attribute_Check_Switch (Attr_Id); end; end if; if State.Detected then State.Diag_Params := Enter_String ("%1%" & To_String (Name_Image ( Attribute_Designator_Identifier (Element)))); end if; end if; end Rule_Check_Pre_Op; ------------------------------------------- -- Rule_Parameter (Forbidden_Attributes) -- ------------------------------------------- overriding function Rule_Parameter (Rule : Forbidden_Attributes_Rule_Type; Diag : String) return String is pragma Unreferenced (Rule); First_Idx : constant Natural := Index (Diag, " ", Going => Backward) + 1; begin return To_Lower (Diag (First_Idx .. Diag'Last)); end Rule_Parameter; ------------------------------------------- -- XML_Print_Rule (Forbidden_Attributes) -- ------------------------------------------- overriding procedure XML_Print_Rule (Rule : Forbidden_Attributes_Rule_Type; Indent_Level : Natural := 0) is All_On : Boolean := True; begin XML_Report ("", Indent_Level); -- Special case: all attributes are ON for J in Asis.Attribute_Kinds'(An_Access_Attribute) .. Asis.Attribute_Kinds'(An_Implementation_Defined_Attribute) loop if Attribute_Check_Switch (J) /= On then All_On := False; exit; end if; end loop; if All_On then XML_Report ("ALL", Indent_Level + 1); goto Done; end if; -- Standard Ada attributes for J in Asis.Attribute_Kinds'(An_Access_Attribute) .. Asis.Attribute_Kinds'(A_Wide_Wide_Width_Attribute) loop if Attribute_Check_Switch (J) = On then XML_Report ("" & Ada_Attribute_Designator (J) & "", Indent_Level + 1); end if; end loop; case Attribute_Check_Switch (An_Implementation_Defined_Attribute) is when Off => null; when On => XML_Report ("GNAT", Indent_Level + 1); when Selective => for J in GNAT_Attribute_Check_Switch'Range loop if GNAT_Attribute_Check_Switch (J) then XML_Report ("" & GNAT_Attribute_Designator (J) & "", Indent_Level + 1); end if; end loop; end case; <> XML_Report ("", Indent_Level); end XML_Print_Rule; ------------------------------------------ -- XML_Rule_Help (Forbidden_Attributes) -- ------------------------------------------ procedure XML_Rule_Help (Rule : Forbidden_Attributes_Rule_Type; Level : Natural) is begin Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); end XML_Rule_Help; ----------------------- -- Forbidden_Pragmas -- ----------------------- -------------------------------------------------------- -- Data structures and local subprograms for the rule -- -------------------------------------------------------- Pragma_Check_Switch : array (Asis.Pragma_Kinds'(An_All_Calls_Remote_Pragma) .. Asis.Pragma_Kinds'(An_Unknown_Pragma)) of Check_Status := (others => Off); -- Specifies which pragma should be detected. GNAT_Pragma_Check_Switch : array (Snames.Pragma_Id) of Boolean := (others => False); -- Specifies which GNAT-specific pragmas should be detected. Note, that -- the index range covers all the pragma IDs, both standard and -- GNAT-specific, but only those components that correspond to -- GNAT-specific pragmas are referenced function Get_Pragma_Kind (S : String) return Pragma_Kinds; -- Tries to get from its argument (that is treated as a pragma name and is -- supposed to be obtained from the rule parameter) the corresponding -- ASIS Pragma_Kinds value. If S does not have a structure of an -- identifier, returns Not_A_Pragma function Get_GNAT_Pragma_Id (S : String) return Snames.Pragma_Id; -- Supposing that S is a name of a GNAT pragma, computes its Pragma_Id. -- Returns Unknown_Pragma if the argument is not a name of a GNAT-specific -- pragma. ----------------------------------------------- -- Activate_In_Test_Mode (Forbidden_Pragmas) -- ----------------------------------------------- overriding procedure Activate_In_Test_Mode (Rule : in out Forbidden_Pragmas_Rule_Type) is begin Process_Rule_Parameter (Rule => Rule, Param => "Inline", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Suppress", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Initialize_Scalars", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Keep_Names", Enable => True, Defined_At => ""); end Activate_In_Test_Mode; -------------------------------------------------------- -- Allowed_As_Exemption_Parameter (Forbidden_Pragmas) -- -------------------------------------------------------- overriding function Allowed_As_Exemption_Parameter (Rule : Forbidden_Pragmas_Rule_Type; Parameter : String) return Boolean is pragma Unreferenced (Rule); begin return Get_Pragma_Kind (Parameter) in Pragma_Kinds'Succ (Not_A_Pragma) .. An_Implementation_Defined_Pragma; end Allowed_As_Exemption_Parameter; -------------------------------------------- -- Get_GNAT_Pragma_Id (Forbidden_Pragmas) -- -------------------------------------------- function Get_GNAT_Pragma_Id (S : String) return Snames.Pragma_Id is use Namet; Result : Snames.Pragma_Id := Snames.Unknown_Pragma; Pragma_Name_Id : Namet.Name_Id; begin if Is_Identifier (To_Wide_String (S)) then Name_Len := S'Length; Name_Buffer (1 .. Name_Len) := To_Lower (S); Pragma_Name_Id := Name_Find; Result := Snames.Get_Pragma_Id (Pragma_Name_Id); end if; return Result; end Get_GNAT_Pragma_Id; ----------------------------------------- -- Get_Pragma_Kind (Forbidden_Pragmas) -- ----------------------------------------- function Get_Pragma_Kind (S : String) return Pragma_Kinds is use type Snames.Pragma_Id; Result : Pragma_Kinds := Not_A_Pragma; begin if Is_Identifier (To_Wide_String (S)) then begin case To_Lower (S (S'First)) is when 'a' | 'e' | 'i' | 'o' | 'u' => Result := Pragma_Kinds'Value ("an_" & S & "_pragma"); when others => Result := Pragma_Kinds'Value ("a_" & S & "_pragma"); end case; exception when Constraint_Error => Result := An_Unknown_Pragma; end; end if; if Result = An_Unknown_Pragma then -- We can have a GNAT-specific pragma here! if Get_GNAT_Pragma_Id (S) /= Snames.Unknown_Pragma then Result := An_Implementation_Defined_Pragma; end if; end if; return Result; end Get_Pragma_Kind; ----------------------------------- -- Init_Rule (Forbidden_Pragmas) -- ----------------------------------- procedure Init_Rule (Rule : in out Forbidden_Pragmas_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Forbidden_Pragmas"); Rule.Synonym := new String'("Pragma_Usage"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("usage of specified pragmas"); Rule.Diagnosis := new String'("use of pragma %1%"); end Init_Rule; ------------------------------------ -- Print_Rule (Forbidden_Pragmas) -- ------------------------------------ procedure Print_Rule (Rule : Forbidden_Pragmas_Rule_Type; Indent_Level : Natural := 0) is All_On : Boolean := True; First_Param : Boolean := True; Rule_Name_Pad : constant String (1 .. Rule_Name (Rule)'Length + 2) := (others => ' '); begin Print_Rule (Rule_Template (Rule), Indent_Level); -- Special case: all pragmas are ON for J in Asis.Pragma_Kinds'(An_All_Calls_Remote_Pragma) .. Asis.Pragma_Kinds'(An_Implementation_Defined_Pragma) loop if Pragma_Check_Switch (J) /= On then All_On := False; exit; end if; end loop; if All_On then Report_No_EOL (": ALL"); return; end if; -- Standard Ada pragmas for J in Asis.Pragma_Kinds'(An_All_Calls_Remote_Pragma) .. Asis.Pragma_Kinds'(An_Unsuppress_Pragma) loop if Pragma_Check_Switch (J) = On then if First_Param then Report_No_EOL (": " & Ada_Pragma_Identifier (J)); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Pad & Ada_Pragma_Identifier (J), Indent_Level); end if; end if; end loop; case Pragma_Check_Switch (An_Implementation_Defined_Pragma) is when Off => null; when On => if First_Param then Report_No_EOL (": GNAT"); else Report (","); Report_No_EOL (Rule_Name_Pad & "GNAT", Indent_Level); end if; when Selective => for J in GNAT_Pragma_Check_Switch'Range loop if GNAT_Pragma_Check_Switch (J) then if First_Param then Report_No_EOL (": " & GNAT_Pragma_Identifier (J)); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Pad & GNAT_Pragma_Identifier (J), Indent_Level); end if; end if; end loop; end case; end Print_Rule; -------------------------------------------- -- Print_Rule_To_File (Forbidden_Pragmas) -- -------------------------------------------- overriding procedure Print_Rule_To_File (Rule : Forbidden_Pragmas_Rule_Type; Rule_File : File_Type; Indent_Level : Natural := 0) is All_On : Boolean := True; First_Param : Boolean := True; Rule_Name_Pad : constant String (1 .. Rule_Name (Rule)'Length + 2) := (others => ' '); begin Print_Rule_To_File (Rule_Template (Rule), Rule_File, Indent_Level); -- Special case: all pragmas are ON for J in Asis.Pragma_Kinds'(An_All_Calls_Remote_Pragma) .. Asis.Pragma_Kinds'(An_Implementation_Defined_Pragma) loop if Pragma_Check_Switch (J) /= On then All_On := False; exit; end if; end loop; if All_On then Put (Rule_File, ": ALL"); return; end if; -- Standard Ada pragmas for J in Asis.Pragma_Kinds'(An_All_Calls_Remote_Pragma) .. Asis.Pragma_Kinds'(An_Unsuppress_Pragma) loop if Pragma_Check_Switch (J) = On then if First_Param then Put (Rule_File, ": " & Ada_Pragma_Identifier (J)); First_Param := False; else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Pad & Ada_Pragma_Identifier (J)); end if; end if; end loop; case Pragma_Check_Switch (An_Implementation_Defined_Pragma) is when Off => null; when On => if First_Param then Put (Rule_File, ": GNAT"); else Put (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Pad & "GNAT"); end if; when Selective => for J in GNAT_Pragma_Check_Switch'Range loop if GNAT_Pragma_Check_Switch (J) then if First_Param then Put (Rule_File, ": " & GNAT_Pragma_Identifier (J)); First_Param := False; else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Pad & GNAT_Pragma_Identifier (J)); end if; end if; end loop; end case; end Print_Rule_To_File; ------------------------------------------------ -- Process_Rule_Parameter (Forbidden_Pragmas) -- ------------------------------------------------ procedure Process_Rule_Parameter (Rule : in out Forbidden_Pragmas_Rule_Type; Param : String; Enable : Boolean; Defined_At : String) is pragma Unreferenced (Defined_At); Arg_Kind : Pragma_Kinds; GNAT_Pragma : Snames.Pragma_Id; begin if Param = "" then if Enable then Rule.Rule_State := Enabled; else Rule.Rule_State := Disabled; end if; return; end if; if To_Lower (Param) = "gnat" then if Enable then Pragma_Check_Switch (An_Implementation_Defined_Pragma) := On; Rule.Rule_State := Enabled; else Pragma_Check_Switch (An_Implementation_Defined_Pragma) := Off; end if; return; end if; if To_Lower (Param) = "all" then if Enable then Pragma_Check_Switch := (others => On); GNAT_Pragma_Check_Switch := (others => True); Rule.Rule_State := Enabled; -- Pragma_Check_Switch (An_Implementation_Defined_Pragma) := -- Selective; else Pragma_Check_Switch := (others => Off); GNAT_Pragma_Check_Switch := (others => False); Rule.Rule_State := Disabled; end if; return; end if; Arg_Kind := Get_Pragma_Kind (Param); case Arg_Kind is when Not_A_Pragma => Error ("(" & Rule.Name.all & ") wrong pragma name : " & Param); when An_Implementation_Defined_Pragma => GNAT_Pragma := Get_GNAT_Pragma_Id (Param); if Enable then if Pragma_Check_Switch (Arg_Kind) = Off then Pragma_Check_Switch (Arg_Kind) := Selective; end if; GNAT_Pragma_Check_Switch (GNAT_Pragma) := True; Rule.Rule_State := Enabled; else GNAT_Pragma_Check_Switch (GNAT_Pragma) := False; if Pragma_Check_Switch (An_Implementation_Defined_Pragma) = On then Pragma_Check_Switch (An_Implementation_Defined_Pragma) := Selective; end if; end if; when others => -- Only specific pragma kinds and An_Unknown_Pragma are possible if Enable then Pragma_Check_Switch (Arg_Kind) := On; Rule.Rule_State := Enabled; else Pragma_Check_Switch (Arg_Kind) := Off; end if; end case; end Process_Rule_Parameter; ------------------------------------------- -- Rule_Check_Pre_Op (Forbidden_Pragmas) -- ------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Forbidden_Pragmas_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is El_Kind : constant Pragma_Kinds := Pragma_Kind (Element); pragma Unreferenced (Control); pragma Unreferenced (Rule); begin if Element_Kind (Element) = A_Pragma then if Pragma_Check_Switch (El_Kind) = On then State.Detected := True; elsif Pragma_Check_Switch (El_Kind) = Selective then State.Detected := GNAT_Pragma_Check_Switch (Get_GNAT_Pragma_Id (To_String (Pragma_Name_Image (Element)))); end if; if State.Detected then State.Diag_Params := Enter_String ("%1%" & To_String (Pragma_Name_Image (Element))); end if; end if; end Rule_Check_Pre_Op; ---------------------------------------- -- Rule_Parameter (Forbidden_Pragmas) -- ---------------------------------------- overriding function Rule_Parameter (Rule : Forbidden_Pragmas_Rule_Type; Diag : String) return String is pragma Unreferenced (Rule); First_Idx : constant Natural := Index (Diag, " ", Going => Backward) + 1; begin return To_Lower (Diag (First_Idx .. Diag'Last)); end Rule_Parameter; ---------------------------------------- -- XML_Print_Rule (Forbidden_Pragmas) -- ---------------------------------------- overriding procedure XML_Print_Rule (Rule : Forbidden_Pragmas_Rule_Type; Indent_Level : Natural := 0) is All_On : Boolean := True; begin XML_Report ("", Indent_Level); -- Special case: all pragmas are ON for J in Asis.Pragma_Kinds'(An_All_Calls_Remote_Pragma) .. Asis.Pragma_Kinds'(An_Implementation_Defined_Pragma) loop if Pragma_Check_Switch (J) /= On then All_On := False; exit; end if; end loop; if All_On then XML_Report ("ALL", Indent_Level + 1); goto Done; end if; -- Standard Ada pragmas for J in Asis.Pragma_Kinds'(An_All_Calls_Remote_Pragma) .. Asis.Pragma_Kinds'(An_Unsuppress_Pragma) loop if Pragma_Check_Switch (J) = On then XML_Report ("" & Ada_Pragma_Identifier (J) & "", Indent_Level + 1); end if; end loop; case Pragma_Check_Switch (An_Implementation_Defined_Pragma) is when Off => null; when On => XML_Report ("GNAT", Indent_Level + 1); when Selective => for J in GNAT_Pragma_Check_Switch'Range loop if GNAT_Pragma_Check_Switch (J) then XML_Report ("" & GNAT_Pragma_Identifier (J) & "", Indent_Level + 1); end if; end loop; end case; <> XML_Report ("", Indent_Level); end XML_Print_Rule; --------------------------------------- -- XML_Rule_Help (Forbidden_Pragmas) -- --------------------------------------- procedure XML_Rule_Help (Rule : Forbidden_Pragmas_Rule_Type; Level : Natural) is begin Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); end XML_Rule_Help; ----------------------------- -- Function_Style_Procedures -- ----------------------------- ------------------------------------------- -- Init_Rule (Function_Style_Procedures) -- ------------------------------------------- procedure Init_Rule (Rule : in out Function_Style_Procedures_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Function_Style_Procedures"); Rule.Synonym := new String'("Functionlike_Procedures"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("procedures looking like functions"); Rule.Diagnosis := new String'("procedure can be rewritten as function"); end Init_Rule; --------------------------------------------------- -- Rule_Check_Pre_Op (Function_Style_Procedures) -- --------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Function_Style_Procedures_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Consider_Replacement_With_Function : Boolean := False; begin case Declaration_Kind (Element) is when A_Procedure_Declaration => Consider_Replacement_With_Function := Definition_Kind (Get_Enclosing_Element) /= A_Protected_Definition; when A_Generic_Procedure_Declaration | A_Formal_Procedure_Declaration => Consider_Replacement_With_Function := True; when A_Procedure_Body_Declaration | A_Procedure_Body_Stub => Consider_Replacement_With_Function := Acts_As_Spec (Element); when others => null; end case; if Consider_Replacement_With_Function then State.Detected := Can_Be_Replaced_With_Function (Element); end if; end Rule_Check_Pre_Op; ----------------------------- -- Generics_In_Subprograms -- ----------------------------- ----------------------------------------- -- Init_Rule (Generics_In_Subprograms) -- ----------------------------------------- procedure Init_Rule (Rule : in out Generics_In_Subprograms_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Generics_In_Subprograms"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("definitions of generic units in " & " subprogram bodies"); Rule.Diagnosis := new String'("generic definition in subprogram " & "body starting at line %1%"); end Init_Rule; ------------------------------------------------- -- Rule_Check_Pre_Op (Generics_In_Subprograms) -- ------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Generics_In_Subprograms_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Encl_Body : Asis.Element; Step_Up : Elmt_Idx := 0; begin if Declaration_Kind (Element) in A_Generic_Declaration then Encl_Body := Get_Enclosing_Element; while not Is_Nil (Encl_Body) loop case Declaration_Kind (Encl_Body) is when A_Procedure_Body_Declaration | A_Function_Body_Declaration => State.Detected := True; exit; when A_Generic_Package_Declaration => exit; when others => Step_Up := Step_Up + 1; Encl_Body := Get_Enclosing_Element (Step_Up); end case; end loop; if State.Detected then State.Diag_Params := Enter_String ("%1%" & Element_Span (Encl_Body).First_Line'Img); end if; end if; end Rule_Check_Pre_Op; ----------------------- -- Identifier_Casing -- ----------------------- -------------------------------------------------------- -- Data structures and local subprograms for the rule -- -------------------------------------------------------- type Identifier_Casing_Parameter_Kinds is (Not_A_Parameter, Type_Par, Constant_Par, Exception_Par, Enum_Par, Others_Par, Exclude_Par); type Wildcard_Kinds is (Not_A_Wildcard, Left, -- ABC* Right, -- *ABC Both); -- *ABC* -- ??? function Get_Pattern (W : String; WK : Wildcard_Kinds) return String; -- W is supposed to be a wildcard with '*' stripped away. The function -- returns a pattern that is stored for the given wildcard. If 'ABC' is the -- actual for W the result is: -- -- WK = Not_A_Wildcard -> ABC -- WK = Left -> ABC_ -- WK = Right -> _ABC -- WK = Both -> _ABC_ procedure Check_With_Word_Dictionary (Name : Program_Text_Access; Dict : String_Access_Sets.Set; State : in out Rule_Traversal_State; Not_In_Dict : out Boolean); -- Check Name against dictionary Dict, State is set according to the -- results of the check. Dict is the dictionary that contains only whole -- words but not wildcards. Not_In_Dict is set to False if Name is found in -- Dict and True otherwise function Get_Diag_Variant (E : Asis.Element) return Diagnosis_Variant; -- Detects the diagnosis variant from the argument. function Get_Identifier_Casing_Parameter_Kind (S : String) return Identifier_Casing_Parameter_Kinds; -- If S denotes one of the rule parameters, returns the corresponding -- parameter kind, otherwise Not_A_Parameter is returned function Get_Casing_Scheme (S : String) return Casing_Schemes; -- If S represents one of the casing schemes, returns the corresponding -- literal of Casing_Schemes, and Not_A_Casing_Scheme otherwise. procedure Scan_Dictionary_File (Stored_Exceptions : in out String_Access_Sets.Set; Stored_Wildcards : in out Wildcard_Sets.Set; D_File_Name : String_Access); -- If D_File_Name is the name of an existing file, scans it as a dictionary -- file and places all the valid casing exceptions into Stored_Exceptions. procedure Check_Casing (Name : Program_Text_Access; Wildcards : Wildcard_Sets.Set; Diag_Var : Diagnosis_Variant; Rule : Identifier_Casing_Rule_Type; State : in out Rule_Traversal_State); -- Checks Name against specified casing scheme and the wildcards exceptions -- specified. In case if the argument correspond to some wildcard, the -- check is made that the parts specified by wildcard have the same casing -- as in wildcard, and the rest - casings specified by the Casing parameter -- (this check is skipped if Casing is equal to Not_A_Casing_Scheme). State -- is set according to the check results procedure Find_Next_Pattern (Name : String; Wildcards : Wildcard_Sets.Set; Success : out Boolean; Pattern_Start : out Natural; Pattern : out String_Access; Orig_Wilcard : out String_Access); -- Checks if Name contains any pattern contained in wildcard dictionary. -- If it does not, sets Success OFF, and all the other out parameters are -- undefined. Otherwise sets Success ON, Pattern_Start is the index of the -- start of the pattern in Name, Pattern is the corresponding wildcard with -- '*' cut off, and Orig_Wilcard is the corresponding wildcard in the -- dictionary file. function Follow_Casing_Scheme (Str : Program_Text; Casing : Casing_Schemes; Word_Start : Boolean) return Boolean; -- Checks if Str that is treated as a part of an identifier satisfies the -- Casing. If Word_Start is ON Str is considered as the start of the name -- or a part of the name immediately following the underscore (important -- for mixed case scheme) function Required_Casing_Scheme (Diag_Var : Diagnosis_Variant; Rule : Identifier_Casing_Rule_Type) return Casing_Schemes; -- Using the variant of the diagnosis as the way to detect the -- corresponding kind of the entities to check, gets from Rule the -- corresponding casing scheme. If for the entity kind that corresponds to -- Diag_Var no casing scheme is set, tries the casing defined for others -- entities. ----------------------------- -- "<" (Identifier_Casing) -- ----------------------------- function "<" (Left, Right : Wildcard_Rec) return Boolean is begin return Left.Img < Right.Img; end "<"; ----------------------------------------------- -- Activate_In_Test_Mode (Identifier_Casing) -- ----------------------------------------------- overriding procedure Activate_In_Test_Mode (Rule : in out Identifier_Casing_Rule_Type) is begin Process_Rule_Parameter (Rule => Rule, Param => "Type=upper", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Enum=mixed", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Constant=lower", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Exception=upper", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Others=mixed", Enable => True, Defined_At => ""); -- Now manually define some exceptions: String_Access_Sets.Insert (Rule.Exclude, new String'("UNIT")); String_Access_Sets.Insert (Rule.Exclude, new String'("ASIS")); String_Access_Sets.Insert (Rule.Exclude, new String'("bits1")); Wildcard_Sets.Insert (Rule.Wilcards, (Img => new String'(Get_Pattern ("_IO", Right)), Orig_Img => new String'("*_IO"))); Wildcard_Sets.Insert (Rule.Wilcards, (Img => new String'(Get_Pattern ("_IO", Not_A_Wildcard)), Orig_Img => new String'("*_IO"))); end Activate_In_Test_Mode; -------------------------------------------------------- -- Allowed_As_Exemption_Parameter (Identifier_Casing) -- -------------------------------------------------------- overriding function Allowed_As_Exemption_Parameter (Rule : Identifier_Casing_Rule_Type; Parameter : String) return Boolean is pragma Unreferenced (Rule); Par : constant String := To_Lower (Parameter); begin return Par = "type" or else Par = "constant" or else Par = "enum" or else Par = "exception" or else Par = "others" or else Par = "exclude"; end Allowed_As_Exemption_Parameter; --------------------------------------- -- Annotate_Rule (Identifier_Casing) -- --------------------------------------- overriding function Annotate_Rule (Rule : Identifier_Casing_Rule_Type; Var : Diagnosis_Variant := 0) return String is begin if not Gnatcheck.Options.Mapping_Mode then return ""; else if Var = 1 and then Rule.Type_Casing_Synonym /= null then return " [" & Rule.Type_Casing_Synonym.all & "]"; elsif Var = 2 and then Rule.Constant_Casing_Synonym /= null then return " [" & Rule.Constant_Casing_Synonym.all & "]"; elsif Var = 3 and then Rule.Enum_Casing_Synonym /= null then return " [" & Rule.Enum_Casing_Synonym.all & "]"; elsif Var = 4 and then Rule.Exception_Casing_Synonym /= null then return " [" & Rule.Exception_Casing_Synonym.all & "]"; elsif Var = 5 and then Rule.Others_Casing_Synonym /= null then return " [" & Rule.Others_Casing_Synonym.all & "]"; elsif Var = 6 and then Rule.Exclude_Synonym /= null then return " [" & Rule.Exclude_Synonym.all & "]"; else return " [" & Rule_Name (Rule) & ':' & (case Var is when 1 => "Type", when 2 => "Constant", when 3 => "Enum", when 4 => "Exception", when 5 => "Others", when 6 => "Exclude", when others => "") & "]"; end if; end if; end Annotate_Rule; -------------------------------------- -- Check_Casing (Identifier_Casing) -- -------------------------------------- procedure Check_Casing (Name : Program_Text_Access; Wildcards : Wildcard_Sets.Set; Diag_Var : Diagnosis_Variant; Rule : Identifier_Casing_Rule_Type; State : in out Rule_Traversal_State) is Success : Boolean; Tmp : String_Access; Tmp_Lowercase : String_Access; Wildcard : String_Access; Orig_Wildcard : String_Access; First_N_Idx : Natural; Name_Last : Natural; Casing : constant Casing_Schemes := Required_Casing_Scheme (Diag_Var, Rule); Pattern_Start : Natural; Pattern_End : Natural; begin Tmp := new String'(To_String (Name.all)); if Wildcard_Sets.Is_Empty (Wildcards) then -- A simple case, no wildcard involved if not Follow_Casing_Scheme (Name.all, Casing, Word_Start => True) then State.Detected := True; State.Diagnosis := Diag_Var; State.Diag_Params := Enter_String ("%1%" & Tmp.all & "%2%" & To_Lower (Required_Casing_Scheme (Diag_Var, Rule)'Img)); end if; Free (Tmp); return; end if; Tmp_Lowercase := new String'(To_Lower (To_String (Name.all))); First_N_Idx := Tmp_Lowercase'First; Name_Last := Tmp_Lowercase'Last; Traverse_Name : while First_N_Idx <= Tmp'Last loop Find_Next_Pattern (Name => Tmp_Lowercase (First_N_Idx .. Name_Last), Wildcards => Wildcards, Success => Success, Pattern_Start => Pattern_Start, Pattern => Wildcard, Orig_Wilcard => Orig_Wildcard); if Success then -- Check if the part of the name before pattern follows the casing -- scheme: if not Follow_Casing_Scheme (Str => Name (First_N_Idx .. Pattern_Start - 1), Casing => Casing, Word_Start => True) then State.Detected := True; State.Diagnosis := Diag_Var; State.Diag_Params := Enter_String ("%1%" & Tmp.all & "%2%" & To_Lower (Required_Casing_Scheme (Diag_Var, Rule)'Img)); exit Traverse_Name; end if; -- Check if the pattern has the correct casing Pattern_End := Pattern_Start + Wildcard.all'Length - 1; if Tmp (Pattern_Start .. Pattern_End) /= Wildcard.all then State.Detected := True; State.Diagnosis := 6; State.Diag_Params := Enter_String ("%1%" & Tmp.all & "%2%" & Orig_Wildcard.all); exit Traverse_Name; end if; -- Corner case of 'A' or abcd_D exit Traverse_Name when Pattern_End = Name_Last; First_N_Idx := Pattern_End; else -- Check if the rest of the word follows the casing scheme. if Name (First_N_Idx) = '_' then First_N_Idx := First_N_Idx + 1; end if; if not Follow_Casing_Scheme (Str => Name (First_N_Idx .. Name_Last), Casing => Casing, Word_Start => True) then State.Detected := True; State.Diagnosis := Diag_Var; State.Diag_Params := Enter_String ("%1%" & Tmp.all & "%2%" & To_Lower (Required_Casing_Scheme (Diag_Var, Rule)'Img)); end if; exit Traverse_Name; end if; end loop Traverse_Name; Free (Tmp); Free (Tmp_Lowercase); end Check_Casing; ---------------------------------------------------- -- Check_With_Word_Dictionary (Identifier_Casing) -- ---------------------------------------------------- procedure Check_With_Word_Dictionary (Name : Program_Text_Access; Dict : String_Access_Sets.Set; State : in out Rule_Traversal_State; Not_In_Dict : out Boolean) is C : String_Access_Sets.Cursor; Tmp : String_Access; begin Not_In_Dict := True; Tmp := new String'(To_String (Name.all)); if not String_Access_Sets.Is_Empty (Dict) then C := String_Access_Sets.Find (Container => Dict, Item => Tmp); if String_Access_Sets.Has_Element (C) then Not_In_Dict := False; if String_Access_Sets.Element (C).all /= Tmp.all then State.Detected := True; State.Diagnosis := 6; State.Diag_Params := Enter_String ("%1%" & Tmp.all & "%2%" & String_Access_Sets.Element (C).all); end if; end if; end if; Free (Tmp); end Check_With_Word_Dictionary; -------- -- Eq -- -------- function Eq (Left, Right : Wildcard_Rec) return Boolean is begin return Left.Img = Right.Img; end Eq; ------------------------------------------- -- Find_Next_Pattern (Identifier_Casing) -- ------------------------------------------- procedure Find_Next_Pattern (Name : String; Wildcards : Wildcard_Sets.Set; Success : out Boolean; Pattern_Start : out Natural; Pattern : out String_Access; Orig_Wilcard : out String_Access) is Pattern_C : Wildcard_Sets.Cursor; Pattern_W : Wildcard_Rec; Pattern_End : Natural; Name_End : constant Natural := Name'Last; begin Success := False; Pattern_Start := Name'First; Traverse_Name : while Pattern_Start <= Name_End loop Pattern_End := 0; Find_Subword_End : for J in Pattern_Start + 1 .. Name_End loop if Name (J) = '_' then Pattern_End := J; exit Find_Subword_End; end if; end loop Find_Subword_End; if Pattern_End = 0 then Pattern_End := Name_End; end if; Pattern_W.Img := new String'(Name (Pattern_Start .. Pattern_End)); Pattern_C := Wildcard_Sets.Find (Wildcards, Pattern_W); Free (Pattern_W.Img); if Wildcard_Sets.Has_Element (Pattern_C) then Success := True; Pattern := Wildcard_Sets.Element (Pattern_C).Img; Orig_Wilcard := Wildcard_Sets.Element (Pattern_C).Orig_Img; exit Traverse_Name; else -- Corner case of 'A' or abcd_D exit Traverse_Name when Pattern_Start = Pattern_End; Pattern_Start := Pattern_End; end if; end loop Traverse_Name; end Find_Next_Pattern; ---------------------------------------------- -- Follow_Casing_Scheme (Identifier_Casing) -- ---------------------------------------------- function Follow_Casing_Scheme (Str : Program_Text; Casing : Casing_Schemes; Word_Start : Boolean) return Boolean is Result : Boolean := True; Word_Start_Tmp : Boolean := Word_Start; begin case Casing is when Lower => if Str /= To_Lower_Case (Str) then Result := False; end if; when Upper => if Str /= To_Upper_Case (Str) then Result := False; end if; when Mixed => for J in Str'Range loop if Word_Start_Tmp then if Ada.Wide_Characters.Unicode.Is_Letter (Str (J)) and then Str (J) /= Ada.Wide_Characters.Unicode.To_Upper_Case (Str (J)) then Result := False; exit; elsif Str (J) /= '_' then Word_Start_Tmp := False; end if; elsif Str (J) = '_' then Word_Start_Tmp := True; else if Ada.Wide_Characters.Unicode.Is_Letter (Str (J)) and then Str (J) /= Ada.Wide_Characters.Unicode.To_Lower_Case (Str (J)) then Result := False; exit; end if; end if; end loop; when Not_A_Casing_Scheme => null; end case; return Result; end Follow_Casing_Scheme; ------------------------------------------- -- Get_Casing_Scheme (Identifier_Casing) -- ------------------------------------------- function Get_Casing_Scheme (S : String) return Casing_Schemes is begin return Casing_Schemes'Value (S); exception when Constraint_Error => return Not_A_Casing_Scheme; end Get_Casing_Scheme; ------------------------------------------ -- Get_Diag_Variant (Identifier_Casing) -- ------------------------------------------ function Get_Diag_Variant (E : Asis.Element) return Diagnosis_Variant is Result : Diagnosis_Variant; Tmp : Asis.Element; begin case Flat_Element_Kind (E) is when A_Defining_Enumeration_Literal => Result := 3; when A_Constant_Declaration | A_Deferred_Constant_Declaration | An_Integer_Number_Declaration | A_Real_Number_Declaration => Result := 2; when An_Exception_Declaration | An_Exception_Renaming_Declaration => Result := 4; when An_Ordinary_Type_Declaration | A_Task_Type_Declaration | A_Protected_Type_Declaration | A_Private_Type_Declaration | A_Private_Extension_Declaration | A_Formal_Type_Declaration | An_Incomplete_Type_Declaration | A_Tagged_Incomplete_Type_Declaration | A_Subtype_Declaration => Result := 1; when A_Task_Body_Declaration | A_Protected_Body_Declaration => if Is_Subunit (E) then Tmp := Corresponding_Body_Stub (E); else Tmp := E; end if; if Declaration_Kind (Corresponding_Declaration (Tmp)) in A_Task_Type_Declaration .. A_Protected_Type_Declaration then Result := 1; else Result := 5; end if; when A_Task_Body_Stub | A_Protected_Body_Stub => if Declaration_Kind (Corresponding_Declaration (E)) in A_Task_Type_Declaration .. A_Protected_Type_Declaration then Result := 1; else Result := 5; end if; when An_Object_Renaming_Declaration => if Is_Constant (First_Name (E)) then Result := 2; else Result := 5; end if; when A_Function_Renaming_Declaration => Tmp := Corresponding_Base_Entity (E); if Expression_Kind (Tmp) = A_Selected_Component then Tmp := Selector (Tmp); end if; if Expression_Kind (Tmp) = An_Enumeration_Literal then Result := 3; else Result := 5; end if; when others => Result := 5; end case; return Result; end Get_Diag_Variant; -------------------------------------------------------------- -- Get_Identifier_Casing_Parameter_Kind (Identifier_Casing) -- -------------------------------------------------------------- function Get_Identifier_Casing_Parameter_Kind (S : String) return Identifier_Casing_Parameter_Kinds is begin return Identifier_Casing_Parameter_Kinds'Value (S & "_Par"); exception when Constraint_Error => return Not_A_Parameter; end Get_Identifier_Casing_Parameter_Kind; -------------------------------------- -- Get_Pattern (Identifier_Casing) -- -------------------------------------- function Get_Pattern (W : String; WK : Wildcard_Kinds) return String is begin case WK is when Not_A_Wildcard => return W; when Left => return W & '_'; when Right => return '_' & W; when Both => return '_' & W & '_'; end case; end Get_Pattern; ----------------------------------- -- Init_Rule (Identifier_Casing) -- ----------------------------------- overriding procedure Init_Rule (Rule : in out Identifier_Casing_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Identifier_Casing"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("casing of defining names"); Rule.Type_Casing := Not_A_Casing_Scheme; Rule.Enum_Casing := Not_A_Casing_Scheme; Rule.Constant_Casing := Not_A_Casing_Scheme; Rule.Exception_Casing := Not_A_Casing_Scheme; Rule.Others_Casing := Not_A_Casing_Scheme; Rule.Type_Casing_Def_At := Nil_String_Loc; Rule.Enum_Casing_Def_At := Nil_String_Loc; Rule.Constant_Casing_Def_At := Nil_String_Loc; Rule.Exception_Casing_Def_At := Nil_String_Loc; Rule.Others_Casing_Def_At := Nil_String_Loc; Rule.Exclude := String_Access_Sets.Empty_Set; Rule.Dictionaries := String_Access_Sets.Empty_Set; Rule.Diagnosis := new String'("#1#%1% does not have casing specified for subtype " & "names (%2%)" & "#2#%1% does not have casing specified for constant " & "names (%2%)" & "#3#%1% does not have casing specified for enumeration " & "literals (%2%)" & "#4#%1% does not have casing specified for exception " & "names (%2%)" & "#5#%1% does not have casing specified (%2%)" & "#6#%1% does not have casing specified in the " & "dictionary (%2%)"); end Init_Rule; ------------------------------------ -- Print_Rule (Identifier_Casing) -- ------------------------------------ overriding procedure Print_Rule (Rule : Identifier_Casing_Rule_Type; Indent_Level : Natural := 0) is First_Param : Boolean := True; Rule_Name_Padding : constant String := (1 .. Rule.Name'Length + 2 => ' '); C : String_Access_Sets.Cursor; begin Print_Rule (Rule_Template (Rule), Indent_Level); if Rule.Type_Casing /= Not_A_Casing_Scheme then Report_No_EOL (": Type = " & To_Lower (Rule.Type_Casing'Img)); First_Param := False; end if; if Rule.Enum_Casing /= Not_A_Casing_Scheme then if First_Param then Report_No_EOL (": Enum = " & To_Lower (Rule.Enum_Casing'Img)); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Enum = " & To_Lower (Rule.Enum_Casing'Img), Indent_Level); end if; end if; if Rule.Constant_Casing /= Not_A_Casing_Scheme then if First_Param then Report_No_EOL (": Constant = " & To_Lower (Rule.Constant_Casing'Img)); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Constant = " & To_Lower (Rule.Constant_Casing'Img), Indent_Level); end if; end if; if Rule.Exception_Casing /= Not_A_Casing_Scheme then if First_Param then Report_No_EOL (": Exception = " & To_Lower (Rule.Exception_Casing'Img)); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Exception = " & To_Lower (Rule.Exception_Casing'Img), Indent_Level); end if; end if; if Rule.Others_Casing /= Not_A_Casing_Scheme then if First_Param then Report_No_EOL (": Others = " & To_Lower (Rule.Others_Casing'Img)); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Others = " & To_Lower (Rule.Others_Casing'Img), Indent_Level); end if; end if; if not String_Access_Sets.Is_Empty (Rule.Dictionaries) then C := String_Access_Sets.First (Rule.Dictionaries); while C /= String_Access_Sets.No_Element loop if First_Param then Report_No_EOL (": Exclude = " & String_Access_Sets.Element (C).all); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Exclude = " & String_Access_Sets.Element (C).all, Indent_Level); end if; C := Next (C); end loop; end if; end Print_Rule; -------------------------------------------- -- Print_Rule_To_File (Identifier_Casing) -- -------------------------------------------- overriding procedure Print_Rule_To_File (Rule : Identifier_Casing_Rule_Type; Rule_File : File_Type; Indent_Level : Natural := 0) is First_Param : Boolean := True; Rule_Name_Padding : constant String := (1 .. Rule.Name'Length + 4 => ' '); C : String_Access_Sets.Cursor; begin Print_Rule_To_File (Rule_Template (Rule), Rule_File, Indent_Level); if Rule.Type_Casing /= Not_A_Casing_Scheme then Put (Rule_File, ": Type = " & To_Lower (Rule.Type_Casing'Img)); First_Param := False; end if; if Rule.Enum_Casing /= Not_A_Casing_Scheme then if First_Param then Put (Rule_File, ": Enum = " & To_Lower (Rule.Enum_Casing'Img)); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Enum = " & To_Lower (Rule.Enum_Casing'Img)); end if; end if; if Rule.Constant_Casing /= Not_A_Casing_Scheme then if First_Param then Put (Rule_File, ": Constant = " & To_Lower (Rule.Constant_Casing'Img)); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Constant = " & To_Lower (Rule.Constant_Casing'Img)); end if; end if; if Rule.Exception_Casing /= Not_A_Casing_Scheme then if First_Param then Put (Rule_File, ": Exception = " & To_Lower (Rule.Exception_Casing'Img)); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Exception = " & To_Lower (Rule.Exception_Casing'Img)); end if; end if; if Rule.Others_Casing /= Not_A_Casing_Scheme then if First_Param then Put (Rule_File, ": Others = " & To_Lower (Rule.Others_Casing'Img)); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Others = " & To_Lower (Rule.Others_Casing'Img)); end if; end if; if not String_Access_Sets.Is_Empty (Rule.Dictionaries) then C := String_Access_Sets.First (Rule.Dictionaries); while C /= String_Access_Sets.No_Element loop if First_Param then Put (Rule_File, ": Exclude = " & String_Access_Sets.Element (C).all); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Exclude = " & String_Access_Sets.Element (C).all); end if; C := Next (C); end loop; end if; end Print_Rule_To_File; ------------------------------------------------ -- Process_Rule_Parameter (Identifier_Casing) -- ------------------------------------------------ overriding procedure Process_Rule_Parameter (Rule : in out Identifier_Casing_Rule_Type; Param : String; Enable : Boolean; Defined_At : String) is First_Str_Idx, Last_Str_Idx : Natural; -- Beginning and end of the 'string' part of the parameter, see the -- rule parameter description in the spec. First_Str_Idx is set to 0 if -- the parameter does not contain a '=' character. First_Par_Idx, Last_Par_Idx : Natural; -- If the parameter contains a '=' character, set to point to the -- beginning and the end of the part of the parameter that precedes '='. -- Otherwise First_Par_Idx points to the first, and Last_Par_Idx - to -- the last non-blank character in Param (First_Idx .. Last_Idx) Parameter_Kind : Identifier_Casing_Parameter_Kinds; Casing_Scheme : Casing_Schemes; C : String_Access_Sets.Cursor; Inserted : Boolean := False; Tmp_Str : String_Access; begin if Param = "" then if Enable then Error ("(" & Rule.Name.all & ") +R option must have a parameter"); else Rule.Rule_State := Disabled; end if; return; elsif not Enable then Error ("(" & Rule.Name.all & ") -R option should not " & "have a parameter"); end if; Parse_Par (First_Par_Idx, Last_Par_Idx, First_Str_Idx, Last_Str_Idx, Param); Parameter_Kind := Get_Identifier_Casing_Parameter_Kind (Param (First_Par_Idx .. Last_Par_Idx)); if Parameter_Kind = Not_A_Parameter or else First_Str_Idx = 0 then Error ("(" & Rule.Name.all & ") wrong parameter: " & Param & ", ignored"); return; end if; -- If we are here, we have "+R=string" if Parameter_Kind in Type_Par .. Others_Par then Casing_Scheme := Get_Casing_Scheme (Param (First_Str_Idx .. Last_Str_Idx)); if Casing_Scheme = Not_A_Casing_Scheme then Error ("(" & Rule.Name.all & ") wrong casing scheme: " & Param & ", ignored"); return; end if; end if; case Parameter_Kind is when Type_Par => if Gnatcheck.Options.Check_Param_Redefinition and then Rule.Type_Casing /= Not_A_Casing_Scheme and then Rule.Type_Casing /= Casing_Scheme -- We do not check if Rule.Rule_State = Enabled because the -- disabled rule remembers all the previous settings then Error ("redefining at " & (if Defined_At = "" then "command line" else Defined_At) & " type casing for rule " & Rule.Name.all & " defined at " & (if Rule.Type_Casing_Def_At = Nil_String_Loc then "command line" else Get_String (Rule.Type_Casing_Def_At))); end if; Rule.Type_Casing := Casing_Scheme; Rule.Type_Casing_Def_At := Enter_String (Defined_At); if Has_Synonym (Rule) then Free (Rule.Type_Casing_Synonym); Rule.Type_Casing_Synonym := new String'(Rule_Synonym (Rule)); end if; when Constant_Par => if Gnatcheck.Options.Check_Param_Redefinition and then Rule.Constant_Casing /= Not_A_Casing_Scheme and then Rule.Constant_Casing /= Casing_Scheme -- We do not check if Rule.Rule_State = Enabled because the -- disabled rule remembers all the previous settings then Error ("redefining at " & (if Defined_At = "" then "command line" else Defined_At) & " constant casing for rule " & Rule.Name.all & " defined at " & (if Rule.Constant_Casing_Def_At = Nil_String_Loc then "command line" else Get_String (Rule.Constant_Casing_Def_At))); end if; Rule.Constant_Casing := Casing_Scheme; Rule.Constant_Casing_Def_At := Enter_String (Defined_At); if Has_Synonym (Rule) then Free (Rule.Constant_Casing_Synonym); Rule.Constant_Casing_Synonym := new String'(Rule_Synonym (Rule)); end if; when Exception_Par => if Gnatcheck.Options.Check_Param_Redefinition and then Rule.Exception_Casing /= Not_A_Casing_Scheme and then Rule.Exception_Casing /= Casing_Scheme -- We do not check if Rule.Rule_State = Enabled because the -- disabled rule remembers all the previous settings then Error ("redefining at " & (if Defined_At = "" then "command line" else Defined_At) & " exception casing for rule " & Rule.Name.all & " defined at " & (if Rule.Exception_Casing_Def_At = Nil_String_Loc then "command line" else Get_String (Rule.Exception_Casing_Def_At))); end if; Rule.Exception_Casing := Casing_Scheme; Rule.Exception_Casing_Def_At := Enter_String (Defined_At); if Has_Synonym (Rule) then Free (Rule.Exception_Casing_Synonym); Rule.Exception_Casing_Synonym := new String'(Rule_Synonym (Rule)); end if; when Enum_Par => if Gnatcheck.Options.Check_Param_Redefinition and then Rule.Enum_Casing /= Not_A_Casing_Scheme and then Rule.Enum_Casing /= Casing_Scheme -- We do not check if Rule.Rule_State = Enabled because the -- disabled rule remembers all the previous settings then Error ("redefining at " & (if Defined_At = "" then "command line" else Defined_At) & " enumeration literal casing for rule " & Rule.Name.all & " defined at " & (if Rule.Enum_Casing_Def_At = Nil_String_Loc then "command line" else Get_String (Rule.Enum_Casing_Def_At))); end if; Rule.Enum_Casing := Casing_Scheme; Rule.Enum_Casing_Def_At := Enter_String (Defined_At); if Has_Synonym (Rule) then Free (Rule.Enum_Casing_Synonym); Rule.Enum_Casing_Synonym := new String'(Rule_Synonym (Rule)); end if; when Others_Par => if Gnatcheck.Options.Check_Param_Redefinition and then Rule.Others_Casing /= Not_A_Casing_Scheme and then Rule.Others_Casing /= Casing_Scheme -- We do not check if Rule.Rule_State = Enabled because the -- disabled rule remembers all the previous settings then Error ("redefining at " & (if Defined_At = "" then "command line" else Defined_At) & " name casing for rule " & Rule.Name.all & " defined at " & (if Rule.Others_Casing_Def_At = Nil_String_Loc then "command line" else Get_String (Rule.Others_Casing_Def_At))); end if; Rule.Others_Casing := Casing_Scheme; Rule.Others_Casing_Def_At := Enter_String (Defined_At); if Has_Synonym (Rule) then Free (Rule.Others_Casing_Synonym); Rule.Others_Casing_Synonym := new String'(Rule_Synonym (Rule)); if Rule.Type_Casing = Not_A_Casing_Scheme then Rule.Type_Casing_Synonym := new String'(Rule_Synonym (Rule)); end if; if Rule.Constant_Casing = Not_A_Casing_Scheme then Rule.Constant_Casing_Synonym := new String'(Rule_Synonym (Rule)); end if; if Rule.Enum_Casing = Not_A_Casing_Scheme then Rule.Enum_Casing_Synonym := new String'(Rule_Synonym (Rule)); end if; if Rule.Exception_Casing = Not_A_Casing_Scheme then Rule.Exception_Casing_Synonym := new String'(Rule_Synonym (Rule)); end if; end if; when Exclude_Par => Tmp_Str := new String'(Param (First_Str_Idx .. Last_Str_Idx)); String_Access_Sets.Insert (Container => Rule.Dictionaries, New_Item => Tmp_Str, Position => C, Inserted => Inserted); if not Inserted then Error ("(" & Rule.Name.all & ") dictionary " & Tmp_Str.all & ", specified more than once, " & "all but first ignored"); Free (Tmp_Str); return; end if; if not Is_Regular_File (Tmp_Str.all) then Error ("(" & Rule.Name.all & ") dictionary " & Tmp_Str.all & " does not exist"); return; end if; Scan_Dictionary_File (Rule.Exclude, Rule.Wilcards, Tmp_Str); if Has_Synonym (Rule) then Free (Rule.Exclude_Synonym); Rule.Exclude_Synonym := new String'(Rule_Synonym (Rule)); end if; when Not_A_Parameter => null; end case; Rule.Rule_State := Enabled; end Process_Rule_Parameter; ------------------------------------------------ -- Required_Casing_Scheme (Identifier_Casing) -- ------------------------------------------------ function Required_Casing_Scheme (Diag_Var : Diagnosis_Variant; Rule : Identifier_Casing_Rule_Type) return Casing_Schemes is Result : Casing_Schemes := Not_A_Casing_Scheme; begin case Diag_Var is when 1 => Result := Rule.Type_Casing; when 2 => Result := Rule.Constant_Casing; when 3 => Result := Rule.Enum_Casing; when 4 => Result := Rule.Exception_Casing; when 5 => Result := Rule.Others_Casing; when others => pragma Assert (False); null; end case; if Result = Not_A_Casing_Scheme then Result := Rule.Others_Casing; end if; return Result; end Required_Casing_Scheme; ------------------------------------------- -- Rule_Check_Pre_Op (Identifier_Casing) -- ------------------------------------------- overriding procedure Rule_Check_Pre_Op (Rule : in out Identifier_Casing_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Control); Tmp : Asis.Element := Element; Name_Img : Program_Text_Access; Not_In_Word_Dictionary : Boolean; begin case Defining_Name_Kind (Element) is when A_Defining_Identifier => Tmp := Get_Enclosing_Element; when A_Defining_Enumeration_Literal => null; when others => return; end case; Name_Img := new Program_Text'(Defining_Name_Image (Element)); Check_With_Word_Dictionary (Name => Name_Img, Dict => Rule.Exclude, State => State, Not_In_Dict => Not_In_Word_Dictionary); if Not_In_Word_Dictionary then Check_Casing (Name => Name_Img, Wildcards => Rule.Wilcards, Diag_Var => Get_Diag_Variant (Tmp), Rule => Rule, State => State); end if; Free (Name_Img); end Rule_Check_Pre_Op; ---------------------------------------- -- Rule_Parameter (Identifier_Casing) -- ---------------------------------------- overriding function Rule_Parameter (Rule : Identifier_Casing_Rule_Type; Diag : String) return String is pragma Unreferenced (Rule); First_Idx : Natural := Index (Diag, " for "); begin if First_Idx > 0 then First_Idx := First_Idx + 5; case Diag (First_Idx) is when 'c' => return "constant"; when 'e' => if Diag (First_Idx + 1) = 'n' then return "enum"; else return "exception"; end if; when 's' => return "type"; when others => raise Constraint_Error with "Identifier_Casing: bug in exemption parameter processing"; end case; end if; First_Idx := Index (Diag, " in "); if First_Idx > 0 then return "exclude"; else return "others"; end if; end Rule_Parameter; ---------------------------------------------- -- Scan_Dictionary_File (Identifier_Casing) -- ---------------------------------------------- procedure Scan_Dictionary_File (Stored_Exceptions : in out String_Access_Sets.Set; Stored_Wildcards : in out Wildcard_Sets.Set; D_File_Name : String_Access) is Dictionary_File : File_Type; String_Buffer_Max_Len : constant Natural := 1024; -- Should be enough, I hope... String_Buffer : String (1 .. String_Buffer_Max_Len); Len : Natural range 0 .. String_Buffer_Max_Len := 0; -- The length of the dictionary file line which is being processed Line_Num : Natural := 0; -- The number of the currently processed line Start_Word : Natural := 0; End_Word : Natural := 0; Start_Wildcard : Natural := 0; End_Wildcard : Natural := 0; Wildcard_Kind : Wildcard_Kinds; C : String_Access_Sets.Cursor; C_W : Wildcard_Sets.Cursor; Tmp_Str : String_Access; New_Wildcard : Wildcard_Rec; begin begin Open (File => Dictionary_File, Mode => In_File, Name => D_File_Name.all); exception when others => Error ("cannot open dictionary file " & D_File_Name.all); return; end; while not End_Of_File (Dictionary_File) loop Line_Num := Line_Num + 1; Get_Line (Dictionary_File, String_Buffer, Len); Start_Word := 1; Scan_Line : while Start_Word <= Len loop while Is_White_Space (String_Buffer (Start_Word)) loop Start_Word := Start_Word + 1; exit Scan_Line when Start_Word > Len; end loop; if Start_Word < Len and then String_Buffer (Start_Word .. Start_Word + 1) = "--" then -- Skip comment exit Scan_Line; end if; End_Word := Len; for J in Start_Word + 1 .. Len loop if Is_White_Space (String_Buffer (J)) then End_Word := J - 1; exit; end if; end loop; if Is_Identifier (To_Wide_String (String_Buffer (Start_Word .. End_Word))) then Tmp_Str := new String'(String_Buffer (Start_Word .. End_Word)); C := String_Access_Sets.Find (Stored_Exceptions, Tmp_Str); if Has_Element (C) then if String_Access_Sets.Element (C).all /= Tmp_Str.all then String_Access_Sets.Replace_Element (Container => Stored_Exceptions, Position => C, New_Item => Tmp_Str); else Free (Tmp_Str); end if; else String_Access_Sets.Insert (Stored_Exceptions, Tmp_Str); end if; else -- In case of a correctly formatted wildcard we do the -- following. For each wildcard we store a set of patterns that -- can be moved onto this wildcard. Then, when analyzing a -- defining name, we select subwords in it and check if a -- subword can be mapped onto some pattern. For each pattern -- we store the original wildcard to be used in the diagnosis. -- -- For *ABC* we store ABC, _ABC, _ABC_ and ABC_, -- for *ABC we store ABC and _ABC -- for ABC* we store ABC and ABC_ Wildcard_Kind := Both; if String_Buffer (Start_Word) = '*' then Start_Wildcard := Start_Word + 1; else Start_Wildcard := Start_Word; Wildcard_Kind := Left; end if; if String_Buffer (End_Word) = '*' then End_Wildcard := End_Word - 1; else if Wildcard_Kind = Both then Wildcard_Kind := Right; End_Wildcard := End_Word; else Wildcard_Kind := Not_A_Wildcard; end if; end if; if Wildcard_Kind = Not_A_Wildcard or else not Is_Identifier (To_Wide_String (String_Buffer (Start_Wildcard .. End_Wildcard))) or else Index (String_Buffer (Start_Wildcard .. End_Wildcard), "_") /= 0 then Error (D_File_Name.all & ':' & Image (Line_Num) & ':' & Image (Start_Word) & ": wrong syntax of a casing exception"); else New_Wildcard.Orig_Img := new String'(String_Buffer (Start_Word .. End_Word)); for W_Kind in Wildcard_Kinds loop if W_Kind = Not_A_Wildcard or else Wildcard_Kind = Both or else Wildcard_Kind = W_Kind then New_Wildcard.Img := new String'(Get_Pattern (String_Buffer (Start_Wildcard .. End_Wildcard), W_Kind)); C_W := Wildcard_Sets.Find (Stored_Wildcards, New_Wildcard); if Wildcard_Sets.Has_Element (C_W) then if Wildcard_Sets.Element (C_W).Img.all /= New_Wildcard.Img.all then Wildcard_Sets.Replace_Element (Container => Stored_Wildcards, Position => C_W, New_Item => New_Wildcard); else Free (New_Wildcard.Img); end if; else Wildcard_Sets.Insert (Stored_Wildcards, New_Wildcard); end if; end if; end loop; end if; end if; Start_Word := End_Word + 2; end loop Scan_Line; end loop; if Is_Open (Dictionary_File) then Close (Dictionary_File); end if; end Scan_Dictionary_File; ---------------------------------------- -- XML_Print_Rule (Identifier_Casing) -- ---------------------------------------- overriding procedure XML_Print_Rule (Rule : Identifier_Casing_Rule_Type; Indent_Level : Natural := 0) is C : String_Access_Sets.Cursor; begin XML_Report ("", Indent_Level); if Rule.Type_Casing /= Not_A_Casing_Scheme then XML_Report ("Type=" & To_Lower (Rule.Type_Casing'Img) & "", Indent_Level + 1); end if; if Rule.Enum_Casing /= Not_A_Casing_Scheme then XML_Report ("Enum=" & To_Lower (Rule.Enum_Casing'Img) & "", Indent_Level + 1); end if; if Rule.Constant_Casing /= Not_A_Casing_Scheme then XML_Report ("Constant=" & To_Lower (Rule.Constant_Casing'Img) & "", Indent_Level + 1); end if; if Rule.Exception_Casing /= Not_A_Casing_Scheme then XML_Report ("Exception=" & To_Lower (Rule.Exception_Casing'Img) & "", Indent_Level + 1); end if; if Rule.Others_Casing /= Not_A_Casing_Scheme then XML_Report ("Others=" & To_Lower (Rule.Others_Casing'Img) & "", Indent_Level + 1); end if; if not String_Access_Sets.Is_Empty (Rule.Dictionaries) then C := String_Access_Sets.First (Rule.Dictionaries); while C /= String_Access_Sets.No_Element loop XML_Report ("Exclude=" & String_Access_Sets.Element (C).all & "", Indent_Level + 1); C := Next (C); end loop; end if; XML_Report ("", Indent_Level); end XML_Print_Rule; --------------------------------------- -- XML_Rule_Help (Identifier_Casing) -- --------------------------------------- overriding procedure XML_Rule_Help (Rule : Identifier_Casing_Rule_Type; Level : Natural) is begin Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); end XML_Rule_Help; ------------------------- -- Identifier_Suffixes -- ------------------------- -------------------------------------------------------- -- Data structures and local subprograms for the rule -- -------------------------------------------------------- Identifier_Suffixes_Exemption_Parameters : Exemption_Parameters.Set; procedure Free_All_Suffixes (Rule : in out Identifier_Suffixes_Rule_Type); -- Cleans all the name suffixes to check function Has_Suffix (El : Asis.Element; Suffix : Wide_String) return Boolean; -- Checks if the string image of El ends with Suffix. ------------------------------------------------- -- Activate_In_Test_Mode (Identifier_Suffixes) -- ------------------------------------------------- overriding procedure Activate_In_Test_Mode (Rule : in out Identifier_Suffixes_Rule_Type) is begin Process_Rule_Parameter (Rule => Rule, Param => "", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Type_Suffix=_T", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Access_Suffix=_Access(_Access)", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Class_Access_Suffix=_Class_Access", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Class_Subtype_Suffix=_Class", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Constant_Suffix=_C", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Renaming_Suffix=_R", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Access_Obj_Suffix=_PTR", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Interrupt_Suffix=_Interrupt", Enable => True, Defined_At => ""); end Activate_In_Test_Mode; ---------------------------------------------------------- -- Allowed_As_Exemption_Parameter (Identifier_Suffixes) -- ---------------------------------------------------------- overriding function Allowed_As_Exemption_Parameter (Rule : Identifier_Suffixes_Rule_Type; Parameter : String) return Boolean is pragma Unreferenced (Rule); begin return Exemption_Parameters.Contains (Identifier_Suffixes_Exemption_Parameters, Parameter); end Allowed_As_Exemption_Parameter; ----------------------------------------- -- Annotate_Rule (Identifier_Suffixes) -- ----------------------------------------- overriding function Annotate_Rule (Rule : Identifier_Suffixes_Rule_Type; Var : Diagnosis_Variant := 0) return String is begin if not Gnatcheck.Options.Mapping_Mode then return ""; else if Var = 1 and then Rule.Type_Suffix_Synonym /= null then return " [" & Rule.Type_Suffix_Synonym.all & "]"; elsif Var in 2 | 5 and then Rule.Access_Suffix_Synonym /= null then return " [" & Rule.Access_Suffix_Synonym.all & "]"; elsif Var = 3 and then Rule.Constant_Suffix_Synonym /= null then return " [" & Rule.Constant_Suffix_Synonym.all & "]"; elsif Var = 4 and then Rule.Renaming_Suffix_Synonym /= null then return " [" & Rule.Renaming_Suffix_Synonym.all & "]"; elsif Var = 6 and then Rule.Class_Subtype_Suffix_Synonym /= null then return " [" & Rule.Class_Subtype_Suffix_Synonym.all & "]"; elsif Var = 7 and then Rule.Class_Access_Suffix_Synonym /= null then return " [" & Rule.Class_Access_Suffix_Synonym.all & "]"; elsif Var = 8 and then Rule.Access_Obj_Suffix_Synonym /= null then return " [" & Rule.Access_Obj_Suffix_Synonym.all & "]"; elsif Var = 9 and then Rule.Interrupt_Suffix_Synonym /= null then return " [" & Rule.Interrupt_Suffix_Synonym.all & "]"; else return " [" & Rule_Name (Rule) & ':' & (case Var is when 1 => "Type_Suffix", when 2 | 5 => "Access_Suffix", when 3 => "Constant_Suffix", when 4 => "Renaming_Suffix", when 6 => "Class_Subtype_Suffix", when 7 => "Class_Access_Suffix", when 8 => "Access_Obj_Suffix", when 9 => "Interrupt_Suffix", when others => "") & "]"; end if; end if; end Annotate_Rule; --------------------------------------------- -- Free_All_Suffixes (Identifier_Suffixes) -- --------------------------------------------- procedure Free_All_Suffixes (Rule : in out Identifier_Suffixes_Rule_Type) is begin Free (Rule.Type_Suffix); Free (Rule.Access_Suffix); Free (Rule.Access_To_Access_Suffix); Free (Rule.Class_Subtype_Suffix); Free (Rule.Class_Access_Suffix); Free (Rule.Constant_Suffix); Free (Rule.Renaming_Suffix); Free (Rule.Access_Obj_Suffix); Free (Rule.Interrupt_Suffix); Free (Rule.Type_Suffix_Synonym); Free (Rule.Access_Suffix_Synonym); Free (Rule.Class_Subtype_Suffix_Synonym); Free (Rule.Class_Access_Suffix_Synonym); Free (Rule.Constant_Suffix_Synonym); Free (Rule.Renaming_Suffix_Synonym); Free (Rule.Access_Obj_Suffix_Synonym); Free (Rule.Interrupt_Suffix_Synonym); end Free_All_Suffixes; -------------------------------------- -- Has_Suffix (Identifier_Suffixes) -- -------------------------------------- function Has_Suffix (El : Asis.Element; Suffix : Wide_String) return Boolean is Result : Boolean := False; begin -- At the moment this function works with A_Defining_Identifier Elements -- only Result := Suffix = Tail (Source => Defining_Name_Image (El), Count => Suffix'Length); return Result; end Has_Suffix; ------------------------------------- -- Init_Rule (Identifier_Suffixes) -- ------------------------------------- procedure Init_Rule (Rule : in out Identifier_Suffixes_Rule_Type) is use Exemption_Parameters; begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Identifier_Suffixes"); Rule.Synonym := new String'("Misnamed_Identifiers"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("suffixes in defining names"); Rule.Diagnosis := new String'("#1#wrong suffix in type name" & "#2#wrong suffix in access type name" & "#3#wrong suffix in constant name" & "#4#wrong suffix in package renaming" & "#5#wrong suffix in access-to-access type name" & "#6#wrong suffix in class-wide subtype name" & "#7#wrong suffix in access-to-class type name" & "#8#wrong suffix in access object name" & "#9#wrong suffix in interrupt handler name"); -- Exemption parameters: Insert (Identifier_Suffixes_Exemption_Parameters, "type"); Insert (Identifier_Suffixes_Exemption_Parameters, "access"); Insert (Identifier_Suffixes_Exemption_Parameters, "access_obj"); Insert (Identifier_Suffixes_Exemption_Parameters, "class_access"); Insert (Identifier_Suffixes_Exemption_Parameters, "class_subtype"); Insert (Identifier_Suffixes_Exemption_Parameters, "constant"); Insert (Identifier_Suffixes_Exemption_Parameters, "renaming"); Insert (Identifier_Suffixes_Exemption_Parameters, "interrupt"); end Init_Rule; -------------------------------------- -- Print_Rule (Identifier_Suffixes) -- -------------------------------------- procedure Print_Rule (Rule : Identifier_Suffixes_Rule_Type; Indent_Level : Natural := 0) is First_Param : Boolean := True; Rule_Name_Padding : constant String := (1 .. Rule.Name'Length + 2 => ' '); begin Print_Rule (Rule_Template (Rule), Indent_Level); if Rule.Type_Suffix /= null then Report_No_EOL (": Type_Suffix = " & Rule.Type_Suffix.all); First_Param := False; end if; if Rule.Access_Suffix /= null then if First_Param then Report_No_EOL (": Access_Suffix = " & Rule.Access_Suffix.all); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Padding & "Access_Suffix = " & Rule.Access_Suffix.all, Indent_Level); end if; end if; if Rule.Access_To_Access_Suffix /= null then if First_Param then Report_No_EOL (": Access_To_Access_Suffix = " & Rule.Access_To_Access_Suffix.all); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Padding & "Access_To_Access_Suffix = " & Rule.Access_To_Access_Suffix.all, Indent_Level); end if; end if; if Rule.Class_Subtype_Suffix /= null then if First_Param then Report_No_EOL (": Class_Subtype_Suffix = " & Rule.Class_Subtype_Suffix.all); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Padding & "Class_Subtype_Suffix = " & Rule.Class_Subtype_Suffix.all, Indent_Level); end if; end if; if Rule.Class_Access_Suffix /= null then if First_Param then Report_No_EOL (": Class_Access_Suffix = " & Rule.Class_Access_Suffix.all); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Padding & "Class_Access_Suffix = " & Rule.Class_Access_Suffix.all, Indent_Level); end if; end if; if Rule.Constant_Suffix /= null then if First_Param then Report_No_EOL (": = " & Rule.Constant_Suffix.all); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Padding & "Constant_Suffix = " & Rule.Constant_Suffix.all, Indent_Level); end if; end if; if Rule.Renaming_Suffix /= null then if First_Param then Report_No_EOL (": Renaming_Suffix = " & Rule.Renaming_Suffix.all); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Padding & "Renaming_Suffix = " & Rule.Renaming_Suffix.all, Indent_Level); end if; end if; if Rule.Access_Obj_Suffix /= null then if First_Param then Report_No_EOL (": Access_Obj_Suffix = " & Rule.Access_Obj_Suffix.all); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Padding & "Access_Obj_Suffix = " & Rule.Access_Obj_Suffix.all, Indent_Level); end if; end if; if Rule.Interrupt_Suffix /= null then if First_Param then Report_No_EOL (": Interrupt_Suffix = " & Rule.Interrupt_Suffix.all); First_Param := False; else Report (","); Report_No_EOL (Rule_Name_Padding & "Interrupt_Suffix = " & Rule.Interrupt_Suffix.all, Indent_Level); end if; end if; end Print_Rule; ---------------------------------------------- -- Print_Rule_To_File (Identifier_Suffixes) -- ---------------------------------------------- procedure Print_Rule_To_File (Rule : Identifier_Suffixes_Rule_Type; Rule_File : File_Type; Indent_Level : Natural := 0) is First_Param : Boolean := True; Rule_Name_Padding : constant String := (1 .. Rule.Name'Length + 4 => ' '); begin Print_Rule_To_File (Rule_Template (Rule), Rule_File, Indent_Level); if Rule.Type_Suffix /= null then Put (Rule_File, ": Type_Suffix = " & Rule.Type_Suffix.all); First_Param := False; end if; if Rule.Access_Suffix /= null then if First_Param then Put (Rule_File, ": Access_Suffix = " & Rule.Access_Suffix.all); First_Param := False; else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Access_Suffix = " & Rule.Access_Suffix.all); end if; if Rule.Access_To_Access_Suffix /= null then Put (Rule_File, "(" & Rule.Access_To_Access_Suffix.all & ")"); end if; end if; if Rule.Class_Subtype_Suffix /= null then if First_Param then Put (Rule_File, ": Class_Subtype_Suffix = " & Rule.Class_Subtype_Suffix.all); First_Param := False; else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Class_Subtype_Suffix = " & Rule.Class_Subtype_Suffix.all); end if; end if; if Rule.Class_Access_Suffix /= null then if First_Param then Put (Rule_File, ": Class_Access_Suffix = " & Rule.Class_Access_Suffix.all); First_Param := False; else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Class_Access_Suffix = " & Rule.Class_Access_Suffix.all); end if; end if; if Rule.Constant_Suffix /= null then if First_Param then Put (Rule_File, ": Constant_Suffix = " & Rule.Constant_Suffix.all); First_Param := False; else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Constant_Suffix = " & Rule.Constant_Suffix.all); end if; end if; if Rule.Renaming_Suffix /= null then if First_Param then Put (Rule_File, ": Renaming_Suffix = " & Rule.Renaming_Suffix.all); First_Param := False; else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Renaming_Suffix = " & Rule.Renaming_Suffix.all); end if; end if; if Rule.Access_Obj_Suffix /= null then if First_Param then Put (Rule_File, ": Access_Obj_Suffix = " & Rule.Access_Obj_Suffix.all); First_Param := False; else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Access_Obj_Suffix = " & Rule.Access_Obj_Suffix.all); end if; end if; if Rule.Interrupt_Suffix /= null then if First_Param then Put (Rule_File, ": Interrupt_Suffix = " & Rule.Interrupt_Suffix.all); First_Param := False; else Put_Line (Rule_File, ","); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Interrupt_Suffix = " & Rule.Interrupt_Suffix.all); end if; end if; end Print_Rule_To_File; -------------------------------------------------- -- Process_Rule_Parameter (Identifier_Suffixes) -- -------------------------------------------------- procedure Process_Rule_Parameter (Rule : in out Identifier_Suffixes_Rule_Type; Param : String; Enable : Boolean; Defined_At : String) is pragma Unreferenced (Defined_At); First_Str_Idx, Last_Str_Idx : Natural; -- Beginning and end of the 'string' part of the parameter, see the -- rule parameter description in the spec. First_Str_Idx is set to 0 if -- the parameter does not contain a '=' character. Last_Str_Idx_Original : Natural; First_Par_Idx, Last_Par_Idx : Natural; -- If the parameter contains a '=' character, set to point to the -- beginning and the end of the part of the parameter that precedes '='. -- Otherwise First_Par_Idx points to the first, and Last_Par_Idx - to -- the last non-blank character in Param (First_Idx .. Last_Idx) Is_Legal_Suffix : Boolean := False; Is_Legal_Access_Suffix : Boolean := False; begin if Param = "" then if Enable then Rule.Rule_State := Enabled; else Rule.Rule_State := Disabled; end if; return; end if; Parse_Par (First_Par_Idx, Last_Par_Idx, First_Str_Idx, Last_Str_Idx, Param); if First_Str_Idx = 0 then if Enable then if To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "default" then Set_Rule_Defaults (Rule); Rule.Rule_State := Enabled; else Error ("(" & Rule.Name.all & ") wrong parameter : " & Param & ", ignored"); end if; else if To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "all_suffixes" then Free_All_Suffixes (Rule); Rule.Rule_State := Disabled; elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "type_suffix" then Free (Rule.Type_Suffix); Free (Rule.Type_Suffix_Synonym); elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "access_suffix" then Free (Rule.Access_Suffix); Free (Rule.Access_To_Access_Suffix); Free (Rule.Access_Suffix_Synonym); elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "constant_suffix" then Free (Rule.Constant_Suffix); Free (Rule.Constant_Suffix_Synonym); elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "class_subtype_suffix" then Free (Rule.Class_Subtype_Suffix); Free (Rule.Class_Subtype_Suffix_Synonym); elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "class_access_suffix" then Free (Rule.Class_Access_Suffix); Free (Rule.Class_Access_Suffix_Synonym); elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "renaming_suffix" then Free (Rule.Renaming_Suffix); Free (Rule.Renaming_Suffix_Synonym); elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "access_obj_suffix" then Free (Rule.Access_Obj_Suffix); Free (Rule.Access_Obj_Suffix_Synonym); elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "interrupt_suffix" then Free (Rule.Interrupt_Suffix); Free (Rule.Interrupt_Suffix_Synonym); else Error ("(" & Rule.Name.all & ") wrong parameter : " & Param & ", ignored"); end if; end if; else if Enable then Is_Legal_Suffix := Is_Identifier_Suffix (To_Wide_String (Param (First_Str_Idx .. Last_Str_Idx))); if not Is_Legal_Suffix and then To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "access_suffix" then Is_Legal_Access_Suffix := Is_Access_Suffix (Param (First_Str_Idx .. Last_Str_Idx)); end if; if Is_Legal_Suffix then if To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "type_suffix" then Rule.Type_Suffix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Type_Suffix_Synonym); Rule.Type_Suffix_Synonym := new String'(Rule_Synonym (Rule)); end if; Rule.Rule_State := Enabled; elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "access_suffix" then Rule.Access_Suffix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); Rule.Access_To_Access_Suffix := null; if Has_Synonym (Rule) then Free (Rule.Access_Suffix_Synonym); Rule.Access_Suffix_Synonym := new String'(Rule_Synonym (Rule)); end if; Rule.Rule_State := Enabled; elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "class_subtype_suffix" then Rule.Class_Subtype_Suffix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Class_Subtype_Suffix_Synonym); Rule.Class_Subtype_Suffix_Synonym := new String'(Rule_Synonym (Rule)); end if; Rule.Rule_State := Enabled; elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "class_access_suffix" then Rule.Class_Access_Suffix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Class_Access_Suffix_Synonym); Rule.Class_Access_Suffix_Synonym := new String'(Rule_Synonym (Rule)); end if; Rule.Rule_State := Enabled; elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "constant_suffix" then Rule.Constant_Suffix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Constant_Suffix_Synonym); Rule.Constant_Suffix_Synonym := new String'(Rule_Synonym (Rule)); end if; Rule.Rule_State := Enabled; elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "renaming_suffix" then Rule.Renaming_Suffix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Renaming_Suffix_Synonym); Rule.Renaming_Suffix_Synonym := new String'(Rule_Synonym (Rule)); end if; Rule.Rule_State := Enabled; elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "access_obj_suffix" then Rule.Access_Obj_Suffix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Access_Obj_Suffix_Synonym); Rule.Access_Obj_Suffix_Synonym := new String'(Rule_Synonym (Rule)); end if; Rule.Rule_State := Enabled; elsif To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = "interrupt_suffix" then Rule.Interrupt_Suffix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Interrupt_Suffix_Synonym); Rule.Interrupt_Suffix_Synonym := new String'(Rule_Synonym (Rule)); end if; Rule.Rule_State := Enabled; else Error ("(" & Rule.Name.all & ") wrong parameter name : " & Param & ", ignored"); end if; elsif Is_Legal_Access_Suffix then -- In this case we already know that -- To_Lower (Param (First_Par_Idx .. Last_Par_Idx)) = -- "access_suffix" Last_Str_Idx_Original := Last_Str_Idx; Last_Str_Idx := Index (Param (First_Str_Idx .. Last_Str_Idx), "(") - 1; Rule.Access_Suffix := new String'(Trim (Param (First_Str_Idx .. Last_Str_Idx), Right)); First_Str_Idx := Last_Str_Idx + 2; Last_Str_Idx := Last_Str_Idx_Original - 1; Rule.Access_To_Access_Suffix := new String'(Trim (Param (First_Str_Idx .. Last_Str_Idx), Both)); if Has_Synonym (Rule) then Free (Rule.Access_Suffix_Synonym); Rule.Access_Suffix_Synonym := new String'(Rule_Synonym (Rule)); end if; Rule.Rule_State := Enabled; else Error ("(" & Rule.Name.all & ") " & Param (First_Str_Idx .. Last_Str_Idx) & " is not a legal name suffix, ignored"); end if; else Error ("(" & Rule.Name.all & ") wrong parameter : " & Param & ", ignored"); end if; end if; end Process_Rule_Parameter; --------------------------------------------- -- Rule_Check_Pre_Op (Identifier_Suffixes) -- --------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Identifier_Suffixes_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Control); pragma Unmodified (Rule); Tmp : Asis.Element; In_Constant : Boolean := False; Access_Obj_Check_Needed : Boolean := False; begin if Defining_Name_Kind (Element) = A_Defining_Identifier then Tmp := Get_Enclosing_Element; if Defining_Name_Kind (Tmp) = A_Defining_Expanded_Name then Tmp := Get_Enclosing_Element (Steps_Up => 1); end if; case Declaration_Kind (Tmp) is when An_Ordinary_Type_Declaration .. A_Protected_Type_Declaration => case Declaration_Kind (Corresponding_Type_Declaration (Tmp)) is when Not_A_Declaration | An_Incomplete_Type_Declaration | A_Tagged_Incomplete_Type_Declaration => if Rule.Type_Suffix /= null or else Rule.Access_Suffix /= null or else Rule.Class_Access_Suffix /= null then -- Here we have to make the difference between access -- and non-access types Tmp := Type_Declaration_View (Tmp); if Type_Kind (Tmp) = An_Access_Type_Definition then -- First, case of access-to-class type if Rule.Class_Access_Suffix /= null and then Is_Access_To_Class (Tmp) then if not Has_Suffix (Element, To_Wide_String (Rule.Class_Access_Suffix.all)) then State.Detected := True; State.Diagnosis := 7; end if; return; end if; if Rule.Access_Suffix /= null then if Rule.Access_To_Access_Suffix = null then if not Has_Suffix (Element, To_Wide_String (Rule.Access_Suffix.all)) then State.Detected := True; State.Diagnosis := 2; end if; else if Is_Access_To_Access (Tmp, Element) then if not Has_Suffix (Element, To_Wide_String (Rule.Access_Suffix.all & Rule.Access_To_Access_Suffix. all)) then State.Detected := True; State.Diagnosis := 5; end if; else if not Has_Suffix (Element, To_Wide_String (Rule.Access_Suffix.all)) then State.Detected := True; State.Diagnosis := 2; end if; end if; end if; elsif Rule.Access_Suffix = null and then Rule.Type_Suffix /= null and then not Has_Suffix (Element, To_Wide_String (Rule.Type_Suffix.all)) then -- If the suffix for access types is not set, -- but the suffix for type defining name is set, -- treat the name as an ordinary type name. State.Detected := True; State.Diagnosis := 1; end if; else if Rule.Type_Suffix /= null and then not Has_Suffix (Element, To_Wide_String (Rule.Type_Suffix.all)) then State.Detected := True; State.Diagnosis := 1; end if; end if; end if; when others => -- The only real possibility is -- A_Private_Type_Declaration or -- A_Private_Extension_Declaration. In both cases we -- do not check the defining identifier of the -- corresponding type declaration null; end case; when A_Private_Type_Declaration .. A_Private_Extension_Declaration => if Rule.Type_Suffix /= null and then not Has_Suffix (Element, To_Wide_String (Rule.Type_Suffix.all)) then State.Detected := True; State.Diagnosis := 1; end if; when An_Incomplete_Type_Declaration .. A_Tagged_Incomplete_Type_Declaration => null; when A_Subtype_Declaration => if Rule.Class_Subtype_Suffix /= null then Tmp := Type_Declaration_View (Tmp); Tmp := Asis.Definitions.Subtype_Mark (Tmp); if (Attribute_Kind (Tmp) = A_Class_Attribute or else Denotes_Class_Wide_Subtype (Tmp)) and then not Has_Suffix (Element, To_Wide_String (Rule.Class_Subtype_Suffix.all)) then State.Detected := True; State.Diagnosis := 6; end if; end if; when A_Variable_Declaration | A_Constant_Declaration | A_Discriminant_Specification | A_Component_Declaration | A_Parameter_Specification | A_Return_Variable_Specification | A_Return_Constant_Specification | A_Formal_Object_Declaration => In_Constant := Declaration_Kind (Tmp) = A_Constant_Declaration; if In_Constant and then Rule.Access_Obj_Suffix = null and then Rule.Constant_Suffix /= null then -- Check for constant suffix if Is_Nil (Corresponding_Constant_Declaration (Element)) and then not Has_Suffix (Element, To_Wide_String (Rule.Constant_Suffix.all)) then State.Detected := True; State.Diagnosis := 3; end if; elsif Rule.Access_Obj_Suffix /= null and then not (Declaration_Kind (Tmp) = A_Constant_Declaration and then not Is_Nil (Corresponding_Constant_Declaration (Element))) then -- Check for access suffix. The case of a deferred constant -- and the corresponding full constant declarations is -- filtered out Tmp := Object_Declaration_View (Tmp); if Definition_Kind (Tmp) = A_Component_Definition then Tmp := Component_Definition_View (Tmp); end if; case Flat_Element_Kind (Tmp) is when Flat_Access_Definition_Kinds => Access_Obj_Check_Needed := True; when A_Subtype_Indication | A_Component_Definition | An_Identifier | A_Selected_Component | A_Base_Attribute => if Definition_Kind (Tmp) = A_Subtype_Indication then Tmp := Asis.Definitions.Subtype_Mark (Tmp); end if; Tmp := Get_Underlying_Type (Tmp, Stop_At_Private => True); case Declaration_Kind (Tmp) is when A_Formal_Type_Declaration => if Formal_Type_Kind (Type_Declaration_View (Tmp)) = A_Formal_Access_Type_Definition then Access_Obj_Check_Needed := True; end if; when An_Ordinary_Type_Declaration => if Type_Kind (Type_Declaration_View (Tmp)) = An_Access_Type_Definition then Access_Obj_Check_Needed := True; end if; when A_Private_Type_Declaration => -- For private type, we do only one step -- attempting to go from private to full view. -- The reason is that for full unwinding of all -- possible subtyping, derivation and privating -- it is very hard to define which information -- is visible at the place of Element if Full_View_Visible (Type_Decl => Tmp, At_Place => Element) then Tmp := Corresponding_Type_Completion (Tmp); Tmp := Get_Underlying_Type (Tmp, Stop_At_Private => True); if Declaration_Kind (Tmp) = An_Ordinary_Type_Declaration and then Type_Kind (Type_Declaration_View (Tmp)) = An_Access_Type_Definition then Access_Obj_Check_Needed := True; end if; end if; when others => null; end case; when others => null; end case; end if; if Access_Obj_Check_Needed and then not Has_Suffix (Element, To_Wide_String (Rule.Access_Obj_Suffix.all)) then State.Detected := True; State.Diagnosis := 8; elsif not Access_Obj_Check_Needed and then In_Constant and then Rule.Constant_Suffix /= null then if Is_Nil (Corresponding_Constant_Declaration (Element)) and then not Has_Suffix (Element, To_Wide_String (Rule.Constant_Suffix.all)) then State.Detected := True; State.Diagnosis := 3; end if; end if; when A_Deferred_Constant_Declaration => if Rule.Constant_Suffix /= null and then not Has_Suffix (Element, To_Wide_String (Rule.Constant_Suffix.all)) then State.Detected := True; State.Diagnosis := 3; end if; when A_Package_Renaming_Declaration => if Rule.Renaming_Suffix /= null and then not Has_Suffix (Element, To_Wide_String (Rule.Renaming_Suffix.all)) then State.Detected := True; State.Diagnosis := 4; end if; when A_Procedure_Declaration => if Rule.Interrupt_Suffix /= null and then Is_Interrupt_Handler (Tmp) and then not Has_Suffix (Element, To_Wide_String (Rule.Interrupt_Suffix.all)) then State.Detected := True; State.Diagnosis := 9; end if; when others => null; end case; end if; end Rule_Check_Pre_Op; ------------------------------------------ -- Rule_Parameter (Identifier_Suffixes) -- ------------------------------------------ overriding function Rule_Parameter (Rule : Identifier_Suffixes_Rule_Type; Diag : String) return String is pragma Unreferenced (Rule); begin if Index (Diag, "access-to-class") /= 0 then return "class_access"; elsif Index (Diag, "access object") /= 0 then return "access_obj"; elsif Index (Diag, "access") /= 0 then return "access"; elsif Index (Diag, "class-wide") /= 0 then return "class_subtype"; elsif Index (Diag, "constant") /= 0 then return "constant"; elsif Index (Diag, "type") /= 0 then return "type"; elsif Index (Diag, "renaming") /= 0 then return "renaming"; elsif Index (Diag, "interrupt") /= 0 then return "interrupt"; else return ""; end if; end Rule_Parameter; --------------------------------------------- -- Set_Rule_Defaults (Identifier_Suffixes) -- --------------------------------------------- procedure Set_Rule_Defaults (Rule : in out Identifier_Suffixes_Rule_Type) is begin Free_All_Suffixes (Rule); Rule.Type_Suffix := new String'("_T"); Rule.Access_Suffix := new String'("_A"); Rule.Access_To_Access_Suffix := null; Rule.Class_Subtype_Suffix := null; Rule.Class_Access_Suffix := null; Rule.Constant_Suffix := new String'("_C"); Rule.Renaming_Suffix := new String'("_R"); Rule.Interrupt_Suffix := null; end Set_Rule_Defaults; ------------------------------------------ -- XML_Print_Rule (Identifier_Suffixes) -- ------------------------------------------ overriding procedure XML_Print_Rule (Rule : Identifier_Suffixes_Rule_Type; Indent_Level : Natural := 0) is begin XML_Report ("", Indent_Level); if Rule.Type_Suffix /= null then XML_Report ("Type_Suffix=" & Rule.Type_Suffix.all & "", Indent_Level + 1); end if; if Rule.Access_Suffix /= null then XML_Report_No_EOL ("Access_Suffix=" & Rule.Access_Suffix.all, Indent_Level + 1); if Rule.Access_To_Access_Suffix /= null then XML_Report_No_EOL ("(" & Rule.Access_To_Access_Suffix.all & ")"); end if; XML_Report (""); end if; if Rule.Class_Subtype_Suffix /= null then XML_Report ("Class_Subtype_Suffix=" & Rule.Class_Subtype_Suffix.all & "", Indent_Level + 1); end if; if Rule.Class_Access_Suffix /= null then XML_Report ("Class_Access_Suffix=" & Rule.Class_Access_Suffix.all & "", Indent_Level + 1); end if; if Rule.Constant_Suffix /= null then XML_Report ("Constant_Suffix=" & Rule.Constant_Suffix.all & "", Indent_Level + 1); end if; if Rule.Renaming_Suffix /= null then XML_Report ("Renaming_Suffix=" & Rule.Renaming_Suffix.all & "", Indent_Level + 1); end if; if Rule.Access_Obj_Suffix /= null then XML_Report ("Access_Obj_Suffix=" & Rule.Access_Obj_Suffix.all & "", Indent_Level + 1); end if; if Rule.Interrupt_Suffix /= null then XML_Report ("Interrupt_Suffix=" & Rule.Interrupt_Suffix.all & "", Indent_Level + 1); end if; XML_Report ("", Indent_Level); end XML_Print_Rule; ---------------------------------------------------- -- XML_Rule_Parameters_Help (Identifier_Suffixes) -- ---------------------------------------------------- procedure XML_Rule_Help (Rule : Identifier_Suffixes_Rule_Type; Level : Natural) is begin Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); -- Specifying the dependencies between the default suffixes and the -- content of the fields for specific suffixes Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); end XML_Rule_Help; ------------------------- -- Identifier_Prefixes -- ------------------------- -------------------------------------------------------- -- Data structures and local subprograms for the rule -- -------------------------------------------------------- type Identifier_Prefixes_Parameter_Kinds is (Not_A_Parameter, All_Prefixes_Par, Type_Par, Concurrent_Par, Access_Par, Class_Access_Par, Subprogram_Access_Par, Derived_Par, Constant_Par, Exception_Par, Enum_Par, Exclusive_Par); Identifier_Prefixes_Exemption_Parameters : Exemption_Parameters.Set; function Get_Identifier_Prefixes_Parameter_Kind (S : String) return Identifier_Prefixes_Parameter_Kinds; -- If S denotes one of the rule parameters, returns the corresponding -- parameter kind, otherwise Not_A_Parameter is returned procedure Free_All_Prefixes (Rule : in out Identifier_Prefixes_Rule_Type); -- Cleans all the name suffixes to check function At_Least_One_Prefix_Set (R : Identifier_Prefixes_Rule_Type) return Boolean; -- Checks if at least one prefix is specified function Has_Prefix (El : Asis.Element; Prefix : Wide_String) return Boolean; -- Checks if the string image of El ends with Prefix. function Get_Full_Parent_Name (Def : Asis.Element) return Program_Text; -- Provided that Def is a derived type definition, private extension -- definition or the definition of a formal derived type, gives the full -- expanded Ada name of its ancestor type (not including the very top -- Standard package). See ASIS_UL.Utilities.Full_Expanded_Name_Image -- query. function Is_Derived_Type_Par (S : String) return Boolean; -- Checks if S has the format 'full_expaned_type_name:prefix' where -- full_expaned_type_name has the syntax of full expanded type name, and -- prefix is a valid identifier prefix. It can be any number of spaces -- around ':' function Derived_Pref (C : Derived_Prefixes.Cursor) return String; -- Returns the parameter of "+RDerived=" option stored under C in the -- format "full_expanded_name_of_parent_type:prefix" All_Prefixes : String_Access_Sets.Set; function Has_Specific_Prefix (E : Asis.Element) return Boolean; -- Checks if E has one of the prefixes specified for specific kinds of -- entities. (Assumes that E is either of A_Defining_Identifier or -- A_Defining_Enumeration_Literal kind). All the prefixes defined for the -- names of specific entities are supposed to be stored in the All_Prefixes -- set container. When this function is called for the first time, it fills -- in this container with the prefixes defined by rule parameters -------------------------------- -- "=" (Identifier_Prefixes) -- -------------------------------- function "=" (Left, Right : Derived_Pref_Record) return Boolean is begin if Left.Parent_Name = null or else Right.Parent_Name = null then return True; else return To_Lower (Left.Parent_Name.all) = To_Lower (Right.Parent_Name.all); end if; end "="; ------------------------------- -- "<" (Identifier_Prefixes) -- ------------------------------- function "<" (Left, Right : Derived_Pref_Record) return Boolean is begin if Left.Parent_Name = null or else Right.Parent_Name = null then return True; else return To_Lower (Left.Parent_Name.all) < To_Lower (Right.Parent_Name.all); end if; end "<"; function "<" (Left, Right : String_Access) return Boolean is begin if Left = null or else Right = null then return True; else return To_Lower (Left.all) < To_Lower (Right.all); end if; end "<"; ------------------------------------------------- -- Activate_In_Test_Mode (Identifier_Prefixes) -- ------------------------------------------------- overriding procedure Activate_In_Test_Mode (Rule : in out Identifier_Prefixes_Rule_Type) is begin Process_Rule_Parameter (Rule => Rule, Param => "Type=T_", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Concurrent=J_", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Access=P_", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Class_Access=CP_", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Subprogram_Access=F_", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Derived=Ada.Finalization.Controlled:CTRL_", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Enum=E_", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Constant=C_", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Exception= X_", Enable => True, Defined_At => ""); Process_Rule_Parameter (Rule => Rule, Param => "Exclusive", Enable => True, Defined_At => ""); end Activate_In_Test_Mode; ---------------------------------------------------------- -- Allowed_As_Exemption_Parameter (Identifier_Prefixes) -- ---------------------------------------------------------- overriding function Allowed_As_Exemption_Parameter (Rule : Identifier_Prefixes_Rule_Type; Parameter : String) return Boolean is pragma Unreferenced (Rule); begin return Exemption_Parameters.Contains (Identifier_Prefixes_Exemption_Parameters, Parameter); end Allowed_As_Exemption_Parameter; ----------------------------------------- -- Annotate_Rule (Identifier_Prefixes) -- ----------------------------------------- overriding function Annotate_Rule (Rule : Identifier_Prefixes_Rule_Type; Var : Diagnosis_Variant := 0) return String is begin if not Gnatcheck.Options.Mapping_Mode then return ""; else if Var = 1 and then Rule.Type_Prefix_Synonym /= null then return " [" & Rule.Type_Prefix_Synonym.all & "]"; elsif Var in 2 | 3 and then Rule.Concurrent_Prefix_Synonym /= null then return " [" & Rule.Concurrent_Prefix_Synonym.all & "]"; elsif Var = 4 and then Rule.Access_Prefix_Synonym /= null then return " [" & Rule.Access_Prefix_Synonym.all & "]"; elsif Var = 5 and then Rule.Class_Access_Prefix_Synonym /= null then return " [" & Rule.Class_Access_Prefix_Synonym.all & "]"; elsif Var = 6 and then Rule.Subprogram_Access_Prefix_Synonym /= null then return " [" & Rule.Subprogram_Access_Prefix_Synonym.all & "]"; elsif Var = 7 and then Rule.Derived_Prefix_Synonym /= null then return " [" & Rule.Derived_Prefix_Synonym.all & "]"; elsif Var = 8 and then Rule.Constant_Prefix_Synonym /= null then return " [" & Rule.Constant_Prefix_Synonym.all & "]"; elsif Var = 10 and then Rule.Exclusive_Prefix_Synonym /= null then return " [" & Rule.Exclusive_Prefix_Synonym.all & "]"; elsif Var = 9 and then Rule.Enum_Prefix_Synonym /= null then return " [" & Rule.Enum_Prefix_Synonym.all & "]"; elsif Var = 11 and then Rule.Exception_Prefix_Synonym /= null then return " [" & Rule.Exception_Prefix_Synonym.all & "]"; else return " [" & Rule_Name (Rule) & ':' & (case Var is when 1 => "Type", when 2 | 3 => "Concurrent", when 4 => "Access", when 5 => "Class_Acces", when 6 => "Subprogram_Access", when 7 => "Derived", when 8 => "Constant", when 9 => "Enum", when 10 => "Exclusive", when 11 => "Exception", when others => "") & "]"; end if; end if; end Annotate_Rule; --------------------------------------------------- -- At_Least_One_Prefix_Set (Identifier_Prefixes) -- --------------------------------------------------- function At_Least_One_Prefix_Set (R : Identifier_Prefixes_Rule_Type) return Boolean is begin return R.Type_Prefix /= null or else R.Concurrent_Prefix /= null or else R.Access_Prefix /= null or else R.Class_Access_Prefix /= null or else R.Subprogram_Access_Prefix /= null or else R.Constant_Prefix /= null or else R.Exception_Prefix /= null or else R.Enum_Prefix /= null or else not Is_Empty (R.Derived_Prefix); end At_Least_One_Prefix_Set; ------------------------------- -- Eq (Identifier_Prefixes) -- ------------------------------- function Eq (Left, Right : String_Access) return Boolean is begin if Left = null or else Right = null then return True; else return To_Lower (Left.all) = To_Lower (Right.all); end if; end Eq; ---------------------------------------- -- Derived_Pref (Identifier_Prefixes) -- ---------------------------------------- function Derived_Pref (C : Derived_Prefixes.Cursor) return String is Def_Pref_Rec : constant Derived_Pref_Record := Derived_Prefixes.Element (C); begin return Def_Pref_Rec.Parent_Name.all & ':' & Def_Pref_Rec.Prefix.all; end Derived_Pref; --------------------------------------------- -- Free_All_Prefixes (Identifier_Prefixes) -- --------------------------------------------- procedure Free_All_Prefixes (Rule : in out Identifier_Prefixes_Rule_Type) is begin Free (Rule.Type_Prefix); Free (Rule.Concurrent_Prefix); Free (Rule.Access_Prefix); Free (Rule.Class_Access_Prefix); Free (Rule.Subprogram_Access_Prefix); Free (Rule.Constant_Prefix); Free (Rule.Exception_Prefix); Free (Rule.Enum_Prefix); Free (Rule.Type_Prefix_Synonym); Free (Rule.Concurrent_Prefix_Synonym); Free (Rule.Access_Prefix_Synonym); Free (Rule.Class_Access_Prefix_Synonym); Free (Rule.Subprogram_Access_Prefix_Synonym); Free (Rule.Constant_Prefix_Synonym); Free (Rule.Exception_Prefix_Synonym); Free (Rule.Enum_Prefix_Synonym); Free (Rule.Exclusive_Prefix_Synonym); -- Some memory leak here - we do not free memory for strings. Derived_Prefixes.Clear (Rule.Derived_Prefix); Free (Rule.Derived_Prefix_Synonym); end Free_All_Prefixes; ------------------------------------------------ -- Get_Full_Parent_Name (Identifier_Prefixes) -- ------------------------------------------------ function Get_Full_Parent_Name (Def : Asis.Element) return Program_Text is Parent_Name : Asis.Element := Def; begin case Flat_Element_Kind (Def) is when A_Derived_Type_Definition | A_Derived_Record_Extension_Definition => Parent_Name := Parent_Subtype_Indication (Parent_Name); when A_Private_Extension_Definition => Parent_Name := Ancestor_Subtype_Indication (Parent_Name); when others => null; end case; Parent_Name := Asis.Definitions.Subtype_Mark (Parent_Name); Parent_Name := Normalize_Reference (Parent_Name); Parent_Name := Corresponding_Name_Declaration (Parent_Name); Parent_Name := Corresponding_First_Subtype (Parent_Name); Parent_Name := First_Name (Parent_Name); return Full_Expanded_Name_Image (Parent_Name); end Get_Full_Parent_Name; ------------------------------------------------------------------ -- Get_Identifier_Prefixes_Parameter_Kind (Identifier_Prefixes) -- ------------------------------------------------------------------ function Get_Identifier_Prefixes_Parameter_Kind (S : String) return Identifier_Prefixes_Parameter_Kinds is begin return Identifier_Prefixes_Parameter_Kinds'Value (S & "_Par"); exception when Constraint_Error => return Not_A_Parameter; end Get_Identifier_Prefixes_Parameter_Kind; -------------------------------------- -- Has_Prefix (Identifier_Prefixes) -- -------------------------------------- function Has_Prefix (El : Asis.Element; Prefix : Wide_String) return Boolean is Result : Boolean := False; begin -- At the moment this function works with A_Defining_Identifier Elements -- only Result := Prefix = Head (Source => Defining_Name_Image (El), Count => Prefix'Length); return Result; end Has_Prefix; ----------------------------------------------- -- Has_Specific_Prefix (Identifier_Prefixes) -- ----------------------------------------------- function Has_Specific_Prefix (E : Asis.Element) return Boolean is Name_Img : constant Program_Text := Defining_Name_Image (E); C_All : String_Access_Sets.Cursor; C_Derived : Derived_Prefixes.Cursor; Result : Boolean; begin if String_Access_Sets.Is_Empty (All_Prefixes) then if Identifier_Prefixes_Rule.Type_Prefix /= null then String_Access_Sets.Insert (Container => All_Prefixes, New_Item => new String'(Identifier_Prefixes_Rule.Type_Prefix.all), Position => C_All, Inserted => Result); end if; if Identifier_Prefixes_Rule.Concurrent_Prefix /= null then String_Access_Sets.Insert (Container => All_Prefixes, New_Item => new String'(Identifier_Prefixes_Rule.Concurrent_Prefix.all), Position => C_All, Inserted => Result); end if; if Identifier_Prefixes_Rule.Access_Prefix /= null then String_Access_Sets.Insert (Container => All_Prefixes, New_Item => new String'(Identifier_Prefixes_Rule.Access_Prefix.all), Position => C_All, Inserted => Result); end if; if Identifier_Prefixes_Rule.Class_Access_Prefix /= null then String_Access_Sets.Insert (Container => All_Prefixes, New_Item => new String'(Identifier_Prefixes_Rule.Class_Access_Prefix.all), Position => C_All, Inserted => Result); end if; if Identifier_Prefixes_Rule.Subprogram_Access_Prefix /= null then String_Access_Sets.Insert (Container => All_Prefixes, New_Item => new String' (Identifier_Prefixes_Rule.Subprogram_Access_Prefix.all), Position => C_All, Inserted => Result); end if; if Identifier_Prefixes_Rule.Constant_Prefix /= null then String_Access_Sets.Insert (Container => All_Prefixes, New_Item => new String'(Identifier_Prefixes_Rule.Constant_Prefix.all), Position => C_All, Inserted => Result); end if; if Identifier_Prefixes_Rule.Exception_Prefix /= null then String_Access_Sets.Insert (Container => All_Prefixes, New_Item => new String'(Identifier_Prefixes_Rule.Exception_Prefix.all), Position => C_All, Inserted => Result); end if; if Identifier_Prefixes_Rule.Enum_Prefix /= null then String_Access_Sets.Insert (Container => All_Prefixes, New_Item => new String'(Identifier_Prefixes_Rule.Enum_Prefix.all), Position => C_All, Inserted => Result); end if; if not Derived_Prefixes.Is_Empty (Identifier_Prefixes_Rule.Derived_Prefix) then C_Derived := Derived_Prefixes.First (Identifier_Prefixes_Rule.Derived_Prefix); while C_Derived /= Derived_Prefixes.No_Element loop String_Access_Sets.Insert (Container => All_Prefixes, New_Item => new String'(Derived_Prefixes.Element (C_Derived).Prefix.all), Position => C_All, Inserted => Result); C_Derived := Next (C_Derived); end loop; end if; end if; Result := False; C_All := String_Access_Sets.First (All_Prefixes); while C_All /= String_Access_Sets.No_Element loop if To_Wide_String (String_Access_Sets.Element (C_All).all) = Head (Name_Img, String_Access_Sets.Element (C_All)'Length) then Result := True; exit; end if; C_All := Next (C_All); end loop; return Result; end Has_Specific_Prefix; ------------------------------------- -- Init_Rule (Identifier_Prefixes) -- ------------------------------------- overriding procedure Init_Rule (Rule : in out Identifier_Prefixes_Rule_Type) is use Exemption_Parameters; begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Identifier_Prefixes"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("prefixes in defining names"); Rule.Exclusive := True; Rule.Diagnosis := new String'("#1#%1% does not start with prefix %2% " & "required for subtypes" & "#2#%1% does not start with prefix %2% " & "required for task subtypes" & "#3#%1% does not start with prefix %2% " & "required for protected subtypes" & "#4#%1% does not start with prefix %2% " & "required for access subtypes" & "#5#%1% does not start with prefix %2% " & "required for access-to-class subtypes" & "#6#%1% does not start with prefix %2% " & "required for access-to-subprogram subtypes" & "#7#%1% does not start with prefix %2% " & "required for types derived from %3%" & "#8#%1% does not start with prefix %2% " & "required for constants" & "#9#%1% does not start with prefix %2% " & "required for enumeration literals" & "#10#%1% has prefix reserved for a different " & "identifier kind" & "#11#%1% does not start with prefix %2% " & "required for exceptions"); -- Exemption parameters: Insert (Identifier_Prefixes_Exemption_Parameters, "type"); Insert (Identifier_Prefixes_Exemption_Parameters, "concurrent"); Insert (Identifier_Prefixes_Exemption_Parameters, "access"); Insert (Identifier_Prefixes_Exemption_Parameters, "class_access"); Insert (Identifier_Prefixes_Exemption_Parameters, "subprogram_access"); Insert (Identifier_Prefixes_Exemption_Parameters, "derived"); Insert (Identifier_Prefixes_Exemption_Parameters, "constant"); Insert (Identifier_Prefixes_Exemption_Parameters, "enum"); Insert (Identifier_Prefixes_Exemption_Parameters, "exception"); Insert (Identifier_Prefixes_Exemption_Parameters, "exclusive"); end Init_Rule; ----------------------------------------------- -- Is_Derived_Type_Par (Identifier_Prefixes) -- ----------------------------------------------- function Is_Derived_Type_Par (S : String) return Boolean is Result : Boolean; First_Idx : constant Natural := S'First; Last_Idx : constant Natural := S'Last; Colon_Idx : constant Natural := Index (S, ":"); begin Result := Is_Ada_Name (To_Wide_String (Trim (S (First_Idx .. Colon_Idx - 1), Both))); if Result then Result := Is_Identifier_Prefix (To_Wide_String (Trim (S (Colon_Idx + 1 .. Last_Idx), Both))); end if; return Result; end Is_Derived_Type_Par; -------------------------------------- -- Print_Rule (Identifier_Prefixes) -- -------------------------------------- overriding procedure Print_Rule (Rule : Identifier_Prefixes_Rule_Type; Indent_Level : Natural := 0) is First_Param : Boolean := True; Rule_Name_Padding : constant String := (1 .. Rule.Name'Length + 2 => ' '); C : Derived_Prefixes.Cursor; begin Print_Rule (Rule_Template (Rule), Indent_Level); if Rule.Type_Prefix /= null then Report_No_EOL (": Type = " & Rule.Type_Prefix.all); First_Param := False; end if; if Rule.Concurrent_Prefix /= null then if First_Param then Report_No_EOL (": Concurrent = " & Rule.Concurrent_Prefix.all); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Concurrent = " & Rule.Concurrent_Prefix.all, Indent_Level); end if; end if; if Rule.Access_Prefix /= null then if First_Param then Report_No_EOL (": Access = " & Rule.Access_Prefix.all); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Access = " & Rule.Access_Prefix.all, Indent_Level); end if; end if; if Rule.Class_Access_Prefix /= null then if First_Param then Report_No_EOL (": Class_Access = " & Rule.Class_Access_Prefix.all); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Class_Access = " & Rule.Class_Access_Prefix.all, Indent_Level); end if; end if; if Rule.Subprogram_Access_Prefix /= null then if First_Param then Report_No_EOL (": Subprogram_Access = " & Rule.Subprogram_Access_Prefix.all); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Subprogram_Access = " & Rule.Subprogram_Access_Prefix.all, Indent_Level); end if; end if; if Rule.Constant_Prefix /= null then if First_Param then Report_No_EOL (": Constant = " & Rule.Constant_Prefix.all); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Constant = " & Rule.Constant_Prefix.all, Indent_Level); end if; end if; if Rule.Exception_Prefix /= null then if First_Param then Report_No_EOL (": Exception = " & Rule.Exception_Prefix.all); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Exception = " & Rule.Exception_Prefix.all, Indent_Level); end if; end if; if Rule.Enum_Prefix /= null then if First_Param then Report_No_EOL (": Enum = " & Rule.Enum_Prefix.all); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Enum = " & Rule.Enum_Prefix.all, Indent_Level); end if; end if; if not Derived_Prefixes.Is_Empty (Rule.Derived_Prefix) then C := Derived_Prefixes.First (Rule.Derived_Prefix); while C /= Derived_Prefixes.No_Element loop if First_Param then Report_No_EOL (": Derived = " & Derived_Pref (C)); First_Param := False; else Report (", "); Report_No_EOL (Rule_Name_Padding & "Derived = " & Derived_Pref (C), Indent_Level); end if; C := Next (C); end loop; end if; -- We have to print out Exclusive parameter, but this would make sense -- only if at least one prefix is specified if not First_Param and then Rule.Exclusive then Report (", "); Report_No_EOL (Rule_Name_Padding & "Exclusive"); end if; end Print_Rule; ---------------------------------------------- -- Print_Rule_To_File (Identifier_Prefixes) -- ---------------------------------------------- overriding procedure Print_Rule_To_File (Rule : Identifier_Prefixes_Rule_Type; Rule_File : File_Type; Indent_Level : Natural := 0) is First_Param : Boolean := True; Rule_Name_Padding : constant String := (1 .. Rule.Name'Length + 4 => ' '); C : Derived_Prefixes.Cursor; begin Print_Rule_To_File (Rule_Template (Rule), Rule_File, Indent_Level); if Rule.Type_Prefix /= null then Put (Rule_File, ": Type = " & Rule.Type_Prefix.all); First_Param := False; end if; if Rule.Concurrent_Prefix /= null then if First_Param then Put (Rule_File, ": Concurrent = " & Rule.Concurrent_Prefix.all); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Concurrent = " & Rule.Concurrent_Prefix.all); end if; end if; if Rule.Access_Prefix /= null then if First_Param then Put (Rule_File, ": Access = " & Rule.Access_Prefix.all); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Access = " & Rule.Access_Prefix.all); end if; end if; if Rule.Class_Access_Prefix /= null then if First_Param then Put (Rule_File, ": Class_Access = " & Rule.Class_Access_Prefix.all); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Class_Access = " & Rule.Class_Access_Prefix.all); end if; end if; if Rule.Subprogram_Access_Prefix /= null then if First_Param then Put (Rule_File, ": Subprogram_Access = " & Rule.Subprogram_Access_Prefix.all); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Subprogram_Access = " & Rule.Subprogram_Access_Prefix.all); end if; end if; if Rule.Constant_Prefix /= null then if First_Param then Put (Rule_File, ": Constant = " & Rule.Constant_Prefix.all); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Constant = " & Rule.Constant_Prefix.all); end if; end if; if Rule.Exception_Prefix /= null then if First_Param then Put (Rule_File, ": Exception = " & Rule.Exception_Prefix.all); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Exception = " & Rule.Exception_Prefix.all); end if; end if; if Rule.Enum_Prefix /= null then if First_Param then Put (Rule_File, ": Enum = " & Rule.Enum_Prefix.all); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Enum = " & Rule.Enum_Prefix.all); end if; end if; if not Derived_Prefixes.Is_Empty (Rule.Derived_Prefix) then C := Derived_Prefixes.First (Rule.Derived_Prefix); while C /= Derived_Prefixes.No_Element loop if First_Param then Put (Rule_File, ": Derived = " & Derived_Pref (C)); First_Param := False; else Put_Line (Rule_File, ", "); for J in 1 .. Indent_Level loop Put (Rule_File, Get_Indent_String); end loop; Put (Rule_File, Rule_Name_Padding & "Derived = " & Derived_Pref (C)); end if; C := Next (C); end loop; end if; -- We have to print out Exclusive parameter, but this would make sense -- only if at least one prefix is specified if not First_Param and then Rule.Exclusive then Put_Line (Rule_File, ", "); Put (Rule_File, Rule_Name_Padding & "Exclusive"); end if; end Print_Rule_To_File; -------------------------------------------------- -- Process_Rule_Parameter (Identifier_Prefixes) -- -------------------------------------------------- overriding procedure Process_Rule_Parameter (Rule : in out Identifier_Prefixes_Rule_Type; Param : String; Enable : Boolean; Defined_At : String) is pragma Unreferenced (Defined_At); First_Str_Idx, Last_Str_Idx : Natural; -- Beginning and end of the 'string' part of the parameter, see the -- rule parameter description in the spec. First_Str_Idx is set to 0 if -- the parameter does not contain a '=' character. First_Par_Idx, Last_Par_Idx : Natural; -- If the parameter contains a '=' character, set to point to the -- beginning and the end of the part of the parameter that precedes '='. -- Otherwise First_Par_Idx points to the first, and Last_Par_Idx - to -- the last non-blank character in Param (First_Idx .. Last_Idx) Is_Legal_Prefix : Boolean := False; Is_Legal_Der_Type_Par : Boolean := False; Parameter_Kind : Identifier_Prefixes_Parameter_Kinds; begin if Param = "" then if Enable then Rule.Rule_State := Enabled; else Rule.Rule_State := Disabled; end if; return; end if; Parse_Par (First_Par_Idx, Last_Par_Idx, First_Str_Idx, Last_Str_Idx, Param); Parameter_Kind := Get_Identifier_Prefixes_Parameter_Kind (Param (First_Par_Idx .. Last_Par_Idx)); if Parameter_Kind = Not_A_Parameter then Error ("(" & Rule.Name.all & ") wrong parameter : " & Param & ", ignored"); return; end if; if First_Str_Idx = 0 then if Enable then -- +R if Parameter_Kind = Exclusive_Par then Rule.Exclusive := True; if Has_Synonym (Rule) then Free (Rule.Exclusive_Prefix_Synonym); Rule.Exclusive_Prefix_Synonym := new String'(Rule_Synonym (Rule)); end if; if At_Least_One_Prefix_Set (Rule) then Rule.Rule_State := Enabled; end if; else Error ("(" & Rule.Name.all & ") wrong parameter : " & Param & ", ignored"); end if; else -- -R case Parameter_Kind is when All_Prefixes_Par => Free_All_Prefixes (Rule); Rule.Rule_State := Disabled; when Type_Par => Free (Rule.Type_Prefix); Free (Rule.Type_Prefix_Synonym); when Concurrent_Par => Free (Rule.Concurrent_Prefix); Free (Rule.Concurrent_Prefix_Synonym); when Access_Par => Free (Rule.Access_Prefix); Free (Rule.Access_Prefix_Synonym); when Class_Access_Par => Free (Rule.Class_Access_Prefix); Free (Rule.Class_Access_Prefix_Synonym); when Subprogram_Access_Par => Free (Rule.Subprogram_Access_Prefix); Free (Rule.Subprogram_Access_Prefix_Synonym); when Derived_Par => Free_All_Prefixes (Rule); Free (Rule.Derived_Prefix_Synonym); when Constant_Par => Free (Rule.Constant_Prefix); Free (Rule.Constant_Prefix_Synonym); when Exception_Par => Free (Rule.Exception_Prefix); Free (Rule.Exception_Prefix_Synonym); when Enum_Par => Free (Rule.Enum_Prefix); Free (Rule.Enum_Prefix_Synonym); when Exclusive_Par => Rule.Exclusive := False; Free (Rule.Exclusive_Prefix_Synonym); when others => pragma Assert (False); return; end case; if not At_Least_One_Prefix_Set (Rule) then Rule.Rule_State := Disabled; end if; end if; else if not Enable or else Parameter_Kind = Exclusive_Par then Error ("(" & Rule.Name.all & ") wrong parameter : " & Param & ", ignored"); return; end if; if Parameter_Kind = Derived_Par then Is_Legal_Der_Type_Par := Is_Derived_Type_Par (Param (First_Str_Idx .. Last_Str_Idx)); else Is_Legal_Prefix := Is_Identifier_Prefix (To_Wide_String (Param (First_Str_Idx .. Last_Str_Idx))); end if; if not (Is_Legal_Prefix or else Is_Legal_Der_Type_Par) then Error ("(" & Rule.Name.all & ") wrong parameter : " & Param & ", ignored"); return; end if; case Parameter_Kind is when Type_Par => Rule.Type_Prefix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Type_Prefix_Synonym); Rule.Type_Prefix_Synonym := new String'(Rule_Synonym (Rule)); end if; when Concurrent_Par => Rule.Concurrent_Prefix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Concurrent_Prefix_Synonym); Rule.Concurrent_Prefix_Synonym := new String'(Rule_Synonym (Rule)); end if; when Access_Par => Rule.Access_Prefix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Access_Prefix_Synonym); Rule.Access_Prefix_Synonym := new String'(Rule_Synonym (Rule)); end if; when Class_Access_Par => Rule.Class_Access_Prefix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Class_Access_Prefix_Synonym); Rule.Class_Access_Prefix_Synonym := new String'(Rule_Synonym (Rule)); end if; when Subprogram_Access_Par => Rule.Subprogram_Access_Prefix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Rule.Subprogram_Access_Prefix_Synonym := new String'(Rule_Synonym (Rule)); end if; when Derived_Par => declare Colon_Idx : constant Natural := Index (Param (First_Str_Idx .. Last_Str_Idx), ":"); New_Pref : Derived_Pref_Record; C : Derived_Prefixes.Cursor; Inserted : Boolean; begin New_Pref.Parent_Name := new String' (Trim (Param (First_Str_Idx .. Colon_Idx - 1), Right)); New_Pref.Prefix := new String' (Trim (Param (Colon_Idx + 1 .. Last_Str_Idx), Left)); Derived_Prefixes.Insert (Container => Rule.Derived_Prefix, New_Item => New_Pref, Position => C, Inserted => Inserted); if not Inserted then Derived_Prefixes.Replace_Element (Container => Rule.Derived_Prefix, Position => C, New_Item => New_Pref); end if; end; if Has_Synonym (Rule) then Free (Rule.Derived_Prefix_Synonym); Rule.Derived_Prefix_Synonym := new String'(Rule_Synonym (Rule)); end if; when Constant_Par => Rule.Constant_Prefix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Constant_Prefix_Synonym); Rule.Constant_Prefix_Synonym := new String'(Rule_Synonym (Rule)); end if; when Exception_Par => Rule.Exception_Prefix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Exception_Prefix_Synonym); Rule.Exception_Prefix_Synonym := new String'(Rule_Synonym (Rule)); end if; when Enum_Par => Rule.Enum_Prefix := new String'(Param (First_Str_Idx .. Last_Str_Idx)); if Has_Synonym (Rule) then Free (Rule.Enum_Prefix_Synonym); Rule.Enum_Prefix_Synonym := new String'(Rule_Synonym (Rule)); end if; when others => pragma Assert (False); return; end case; Rule.Rule_State := Enabled; end if; end Process_Rule_Parameter; --------------------------------------------- -- Rule_Check_Pre_Op (Identifier_Prefixes) -- --------------------------------------------- overriding procedure Rule_Check_Pre_Op (Rule : in out Identifier_Prefixes_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Control); Tmp : Asis.Element; Check_Exclusive : Boolean := False; Derived_Check : Derived_Pref_Record; C_Pref_To_Check : Derived_Prefixes.Cursor; begin case Defining_Name_Kind (Element) is when A_Defining_Identifier => Tmp := Get_Enclosing_Element; if Declaration_Kind (Tmp) = A_Subtype_Declaration then Tmp := Corresponding_First_Subtype (Tmp); end if; when A_Defining_Enumeration_Literal => Tmp := Element; when others => return; end case; case Flat_Element_Kind (Tmp) is when A_Defining_Enumeration_Literal => if Rule.Enum_Prefix /= null then if not Has_Prefix (Element, To_Wide_String (Rule.Enum_Prefix.all)) then State.Detected := True; State.Diagnosis := 9; State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (Element)) & "%2%" & Rule.Enum_Prefix.all); end if; return; else Check_Exclusive := True; end if; when A_Function_Renaming_Declaration => if not Is_Equal (Corresponding_Declaration (Tmp), Tmp) then -- Renaming-as-body, completion of another declaration, so return; end if; Tmp := Corresponding_Base_Entity (Tmp); if Expression_Kind (Tmp) = A_Selected_Component then Tmp := Selector (Tmp); end if; if Expression_Kind (Tmp) = An_Enumeration_Literal then if Rule.Enum_Prefix /= null then if not Has_Prefix (Element, To_Wide_String (Rule.Enum_Prefix.all)) then State.Detected := True; State.Diagnosis := 9; State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (Element)) & "%2%" & Rule.Enum_Prefix.all); end if; return; else Check_Exclusive := True; end if; else Check_Exclusive := True; end if; when A_Procedure_Renaming_Declaration => if not Is_Equal (Corresponding_Declaration (Tmp), Tmp) then -- Renaming-as-body, completion of another declaration, so return; end if; when A_Constant_Declaration | A_Deferred_Constant_Declaration | An_Integer_Number_Declaration | A_Real_Number_Declaration | An_Object_Renaming_Declaration => if Flat_Element_Kind (Tmp) = A_Constant_Declaration and then not Is_Nil (Corresponding_Constant_Declaration (Element)) then -- No check for names from full declarations that correspond to -- deferred constants return; end if; if Flat_Element_Kind (Tmp) /= An_Object_Renaming_Declaration or else Is_Constant (First_Name (Tmp)) then if Rule.Constant_Prefix /= null then if not Has_Prefix (Element, To_Wide_String (Rule.Constant_Prefix.all)) then State.Detected := True; State.Diagnosis := 8; State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (Element)) & "%2%" & Rule.Constant_Prefix.all); end if; return; end if; end if; Check_Exclusive := True; when An_Exception_Declaration | An_Exception_Renaming_Declaration => if Rule.Exception_Prefix /= null then if not Has_Prefix (Element, To_Wide_String (Rule.Exception_Prefix.all)) then State.Detected := True; State.Diagnosis := 11; State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (Element)) & "%2%" & Rule.Exception_Prefix.all); end if; return; else Check_Exclusive := True; end if; when An_Ordinary_Type_Declaration | A_Task_Type_Declaration | A_Protected_Type_Declaration | A_Private_Type_Declaration | A_Private_Extension_Declaration | A_Formal_Type_Declaration => if Flat_Element_Kind (Tmp) in An_Ordinary_Type_Declaration .. A_Protected_Type_Declaration and then Declaration_Kind (Corresponding_Type_Declaration (Tmp)) in A_Private_Type_Declaration .. A_Private_Extension_Declaration then -- No check for full type declarations corresponding to -- private types return; end if; if Flat_Element_Kind (Tmp) in A_Task_Type_Declaration .. A_Protected_Type_Declaration and then Rule.Concurrent_Prefix /= null then if not Has_Prefix (Element, To_Wide_String (Rule.Concurrent_Prefix.all)) then State.Detected := True; if Flat_Element_Kind (Tmp) = A_Task_Type_Declaration then State.Diagnosis := 2; else State.Diagnosis := 3; end if; State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (Element)) & "%2%" & Rule.Concurrent_Prefix.all); end if; return; end if; Tmp := Type_Declaration_View (Tmp); if Type_Kind (Tmp) = An_Access_Type_Definition or else Formal_Type_Kind (Tmp) = A_Formal_Access_Type_Definition then if Access_Type_Kind (Tmp) in An_Access_To_Procedure .. An_Access_To_Protected_Function and then Rule.Subprogram_Access_Prefix /= null then if not Has_Prefix (Element, To_Wide_String (Rule.Subprogram_Access_Prefix.all)) then State.Detected := True; State.Diagnosis := 6; State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (Element)) & "%2%" & Rule.Subprogram_Access_Prefix.all); end if; return; end if; if Is_Access_To_Class (Tmp) and then Rule.Class_Access_Prefix /= null then if not Has_Prefix (Element, To_Wide_String (Rule.Class_Access_Prefix.all)) then State.Detected := True; State.Diagnosis := 5; State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (Element)) & "%2%" & Rule.Class_Access_Prefix.all); end if; return; end if; if Rule.Access_Prefix /= null then if not Has_Prefix (Element, To_Wide_String (Rule.Access_Prefix.all)) then State.Detected := True; State.Diagnosis := 4; State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (Element)) & "%2%" & Rule.Access_Prefix.all); end if; return; end if; end if; if Type_Kind (Tmp) in A_Derived_Type_Definition .. A_Derived_Record_Extension_Definition or else Formal_Type_Kind (Tmp) = A_Formal_Derived_Type_Definition or else Declaration_Kind (Get_Enclosing_Element) = A_Private_Extension_Declaration then Derived_Check.Parent_Name := new String'(To_String (Get_Full_Parent_Name (Tmp))); if Derived_Check.Parent_Name.all /= "" then C_Pref_To_Check := Find (Rule.Derived_Prefix, Derived_Check); if C_Pref_To_Check /= Derived_Prefixes.No_Element then if not Has_Prefix (Element, To_Wide_String (Derived_Prefixes.Element (C_Pref_To_Check).Prefix.all)) then State.Detected := True; State.Diagnosis := 7; State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (Element)) & "%2%" & Derived_Prefixes.Element (C_Pref_To_Check).Prefix.all & "%3%" & Derived_Check.Parent_Name.all); end if; return; end if; end if; end if; if Rule.Type_Prefix /= null then if not Has_Prefix (Element, To_Wide_String (Rule.Type_Prefix.all)) then State.Detected := True; State.Diagnosis := 1; State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (Element)) & "%2%" & Rule.Type_Prefix.all); end if; return; else Check_Exclusive := True; end if; when An_Incomplete_Type_Declaration | A_Tagged_Incomplete_Type_Declaration | A_Formal_Incomplete_Type_Declaration => -- These names are never checked return; when A_Procedure_Body_Stub .. A_Function_Body_Stub => if Is_Nil (Corresponding_Declaration (Tmp)) then Check_Exclusive := True; else -- Completion of another declaration return; end if; when A_Procedure_Body_Declaration | A_Function_Body_Declaration => if Is_Subunit (Tmp) or else not Is_Nil (Corresponding_Declaration (Tmp)) then -- Completion of another declaration return; else Check_Exclusive := True; end if; when A_Package_Body_Declaration | A_Task_Body_Declaration | A_Protected_Body_Declaration | An_Entry_Body_Declaration | A_Package_Body_Stub | A_Task_Body_Stub | A_Protected_Body_Stub => -- Completion of another declaration return; when others => Check_Exclusive := True; end case; if Check_Exclusive and then Rule.Exclusive and then Has_Specific_Prefix (Element) then State.Detected := True; State.Diagnosis := 10; State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (Element))); end if; end Rule_Check_Pre_Op; ------------------------------------------ -- Rule_Parameter (Identifier_Prefixes) -- ------------------------------------------ overriding function Rule_Parameter (Rule : Identifier_Prefixes_Rule_Type; Diag : String) return String is pragma Unreferenced (Rule); begin if Index (Diag, "task") /= 0 or else Index (Diag, "protected") /= 0 then return "concurrent"; elsif Index (Diag, "access-to-class") /= 0 then return "class_acces"; elsif Index (Diag, "access-to-subprogram") /= 0 then return "subprogram_access"; elsif Index (Diag, "derived") /= 0 then return "derived"; elsif Index (Diag, "constants") /= 0 then return "constant"; elsif Index (Diag, "enumeration") /= 0 then return "enum"; elsif Index (Diag, "exceptions") /= 0 then return "exception"; elsif Index (Diag, "access") /= 0 then return "access"; elsif Index (Diag, "subtypes") /= 0 then return "type"; elsif Index (Diag, "reserved") /= 0 then return "exclusive"; else return ""; end if; end Rule_Parameter; ----------------------------------------- -- XML_Rule_Help (Identifier_Prefixes) -- ----------------------------------------- overriding procedure XML_Print_Rule (Rule : Identifier_Prefixes_Rule_Type; Indent_Level : Natural := 0) is C : Derived_Prefixes.Cursor; Prefix_Specified : Boolean := False; begin XML_Report ("", Indent_Level); if Rule.Type_Prefix /= null then XML_Report ("Type=" & Rule.Type_Prefix.all & "", Indent_Level + 1); Prefix_Specified := True; end if; if Rule.Concurrent_Prefix /= null then XML_Report ("Concurrent=" & Rule.Concurrent_Prefix.all & "", Indent_Level + 1); Prefix_Specified := True; end if; if Rule.Access_Prefix /= null then XML_Report ("Access=" & Rule.Access_Prefix.all & "", Indent_Level + 1); Prefix_Specified := True; end if; if Rule.Class_Access_Prefix /= null then XML_Report ("Class_Access=" & Rule.Class_Access_Prefix.all & "", Indent_Level + 1); Prefix_Specified := True; end if; if Rule.Subprogram_Access_Prefix /= null then XML_Report ("Subprogram_Access=" & Rule.Subprogram_Access_Prefix.all & "", Indent_Level + 1); Prefix_Specified := True; end if; if Rule.Constant_Prefix /= null then XML_Report ("Constant=" & Rule.Constant_Prefix.all & "", Indent_Level + 1); Prefix_Specified := True; end if; if Rule.Exception_Prefix /= null then XML_Report ("Exception=" & Rule.Exception_Prefix.all & "", Indent_Level + 1); Prefix_Specified := True; end if; if Rule.Enum_Prefix /= null then XML_Report ("Enum=" & Rule.Enum_Prefix.all & "", Indent_Level + 1); Prefix_Specified := True; end if; if not Derived_Prefixes.Is_Empty (Rule.Derived_Prefix) then C := Derived_Prefixes.First (Rule.Derived_Prefix); while C /= Derived_Prefixes.No_Element loop XML_Report ("Derived=" & Derived_Pref (C) & "", Indent_Level + 1); Prefix_Specified := True; C := Next (C); end loop; end if; -- We have to print out Exclusive parameter, but this would make sense -- only if at least one prefix is specified if Prefix_Specified and then Rule.Exclusive then XML_Report ("Exclusive", Indent_Level + 1); end if; XML_Report ("", Indent_Level); end XML_Print_Rule; ----------------------------------------- -- XML_Rule_Help (Identifier_Prefixes) -- ----------------------------------------- overriding procedure XML_Rule_Help (Rule : Identifier_Prefixes_Rule_Type; Level : Natural) is begin Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); end XML_Rule_Help; --------------------------------- -- Implicit_IN_Mode_Parameters -- --------------------------------- --------------------------------------------- -- Init_Rule (Implicit_IN_Mode_Parameters) -- --------------------------------------------- procedure Init_Rule (Rule : in out Implicit_IN_Mode_Parameters_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Implicit_IN_Mode_Parameters"); Rule.Synonym := new String'("Implicit_IN_Parameter_Mode"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("implicit IN mode in parameter " & "specifications"); Rule.Diagnosis := new String'("implicit IN mode in parameter " & "specification"); end Init_Rule; ----------------------------------------------------- -- Rule_Check_Pre_Op (Implicit_IN_Mode_Parameters) -- ----------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Implicit_IN_Mode_Parameters_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); begin if Declaration_Kind (Element) = A_Parameter_Specification and then Mode_Kind (Element) = A_Default_In_Mode and then Definition_Kind (Object_Declaration_View (Element)) /= An_Access_Definition then State.Detected := True; end if; end Rule_Check_Pre_Op; ------------------------------------------ -- Implicit_SMALL_For_Fixed_Point_Types -- ------------------------------------------ ------------------------------------------------------ -- Init_Rule (Implicit_SMALL_For_Fixed_Point_Types) -- ------------------------------------------------------ procedure Init_Rule (Rule : in out Implicit_SMALL_For_Fixed_Point_Types_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Implicit_SMALL_For_Fixed_Point_Types"); Rule.Synonym := new String'("Missing_Small_For_Fixed_Point_Type"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("fixed point type declarations with no " & "'Small clause"); Rule.Diagnosis := new String'("fixed point type declaration with no " & "'Small clause"); end Init_Rule; -------------------------------------------------------------- -- Rule_Check_Pre_Op (Implicit_SMALL_For_Fixed_Point_Types) -- -------------------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Implicit_SMALL_For_Fixed_Point_Types_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); begin if Type_Kind (Element) = An_Ordinary_Fixed_Point_Definition then State.Detected := True; declare Rep_Clauses : constant Asis.Element_List := Corresponding_Representation_Clauses (Get_Enclosing_Element); begin for J in Rep_Clauses'Range loop if Representation_Clause_Kind (Rep_Clauses (J)) = An_Attribute_Definition_Clause and then Attribute_Kind (Representation_Clause_Name (Rep_Clauses (J))) = A_Small_Attribute then State.Detected := False; exit; end if; end loop; end; end if; end Rule_Check_Pre_Op; --------------------------------------- -- Improperly_Located_Instantiations -- --------------------------------------- --------------------------------------------------- -- Init_Rule (Improperly_Located_Instantiations) -- --------------------------------------------------- procedure Init_Rule (Rule : in out Improperly_Located_Instantiations_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Improperly_Located_Instantiations"); Rule.Synonym := new String'("Unreasonable_Places_For_Instantiations"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("instantiations that can cause problems"); Rule.Diagnosis := new String'("#1#instantiation in a subprogram body" & "#2#instantiation in a library package spec" & "#3#instantiation in a generic library package spec"); end Init_Rule; ----------------------------------------------------------- -- Rule_Check_Pre_Op (Improperly_Located_Instantiations) -- ----------------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Improperly_Located_Instantiations_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Encl_CU : Asis.Compilation_Unit; Encl_Body : Asis.Element; Step_Up : Elmt_Idx := 0; begin if Declaration_Kind (Element) in A_Generic_Instantiation then Encl_CU := Enclosing_Compilation_Unit (Element); case Unit_Kind (Encl_CU) is when A_Package => State.Detected := True; State.Diagnosis := 2; when A_Generic_Package => State.Detected := True; State.Diagnosis := 3; when A_Subprogram_Body | A_Procedure_Body_Subunit | A_Function_Body_Subunit => State.Detected := True; State.Diagnosis := 1; when A_Package_Body | A_Protected_Body_Subunit => Encl_Body := Get_Enclosing_Element; while not Is_Nil (Encl_Body) loop if Declaration_Kind (Encl_Body) in A_Procedure_Body_Declaration .. A_Function_Body_Declaration then State.Detected := True; State.Diagnosis := 1; exit; elsif Declaration_Kind (Encl_Body) = A_Task_Body_Declaration or else Declaration_Kind (Encl_Body) = An_Entry_Body_Declaration then exit; else Step_Up := Step_Up + 1; Encl_Body := Get_Enclosing_Element (Step_Up); end if; end loop; when A_Subprogram_Declaration | A_Generic_Procedure | A_Generic_Function | A_Renaming | A_Generic_Unit_Instance | A_Package_Body_Subunit | A_Task_Body_Subunit | A_Nonexistent_Declaration | A_Nonexistent_Body | A_Configuration_Compilation | An_Unknown_Unit | Not_A_Unit => null; end case; end if; end Rule_Check_Pre_Op; ---------------------- -- Numeric_Indexing -- ---------------------- ---------------------------------- -- Init_Rule (Numeric_Indexing) -- ---------------------------------- procedure Init_Rule (Rule : in out Numeric_Indexing_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Numeric_Indexing"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("use integer literals as indexes"); Rule.Diagnosis := new String'("integer literal as index value"); end Init_Rule; ------------------------------------------ -- Rule_Check_Pre_Op (Numeric_Indexing) -- ------------------------------------------ procedure Rule_Check_Pre_Op (Rule : in out Numeric_Indexing_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); EE : Asis.Element; Call : Asis.Element; Pref : Asis.Element; begin if Expression_Kind (Element) = An_Integer_Literal then EE := Get_Enclosing_Element; if Expression_Kind (EE) = An_Indexed_Component then State.Detected := True; elsif Association_Kind (EE) = A_Parameter_Association then Call := Get_Enclosing_Element (1); EE := Get_Enclosing_Element (2); if Expression_Kind (EE) = An_Indexed_Component then -- Check if we have a call to a predefined unary "-" Pref := Prefix (Call); Pref := Normalize_Reference (Pref); if Operator_Kind (Pref) = A_Unary_Minus_Operator and then Is_Predefined_Operator (Pref) then State.Detected := True; end if; end if; end if; end if; end Rule_Check_Pre_Op; --------------------------------- -- Non_Short_Circuit_Operators -- --------------------------------- --------------------------------------------- -- Init_Rule (Non_Short_Circuit_Operators) -- --------------------------------------------- procedure Init_Rule (Rule : in out Non_Short_Circuit_Operators_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Non_Short_Circuit_Operators"); Rule.Synonym := new String'("Use_Of_Non_Short_Circuit"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("use of predefined AND and OR for " & "boolean types"); Rule.Diagnosis := new String'("#1#use of predefined AND for boolean type" & "#2#use of predefined OR for boolean type"); end Init_Rule; ----------------------------------------------------- -- Rule_Check_Pre_Op (Non_Short_Circuit_Operators) -- ----------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Non_Short_Circuit_Operators_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Call : Asis.Element; begin if Operator_Kind (Element) in An_And_Operator .. An_Or_Operator then Call := Get_Enclosing_Element; if Expression_Kind (Call) = A_Selected_Component then Call := Get_Enclosing_Element (Steps_Up => 1); end if; if Expression_Kind (Call) = A_Function_Call and then Is_Predefined_Operator (Element) and then Is_Boolean_Logical_Op (Element) then State.Detected := True; if Operator_Kind (Element) = An_And_Operator then State.Diagnosis := 1; else State.Diagnosis := 2; end if; end if; end if; end Rule_Check_Pre_Op; ---------------------------- -- Non_Visible_Exceptions -- ---------------------------- -------------------------------------- -- Has_Tip (Non_Visible_Exceptions) -- -------------------------------------- function Has_Tip (Rule : Non_Visible_Exceptions_Rule_Type) return Boolean is pragma Unreferenced (Rule); begin return True; end Has_Tip; ---------------------------------------- -- Init_Rule (Non_Visible_Exceptions) -- ---------------------------------------- procedure Init_Rule (Rule : in out Non_Visible_Exceptions_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Non_Visible_Exceptions"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("potential propagations of " & "non-visible exceptions"); Rule.Diagnosis := new String'("#1#no handler for this exception in enclosing body" & "#2#no handler for this exception in enclosing block" & "#3#propagates the local exception " & "declared at line %1% outside its visibility"); end Init_Rule; ------------------------------------------------ -- Rule_Check_Pre_Op (Non_Visible_Exceptions) -- ------------------------------------------------ procedure Rule_Check_Pre_Op (Rule : in out Non_Visible_Exceptions_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Handler : Asis.Element; Handled_Exc : Asis.Element; Raised_Exc : Asis.Element; Frame : Asis.Element; Step_Up : Elmt_Idx := 0; begin -- First part of the rule - declarations of local non-handled -- exceptions: if Defining_Name_Kind (Element) = A_Defining_Identifier and then Declaration_Kind (Get_Enclosing_Element) = An_Exception_Declaration and then (Declaration_Kind (Get_Enclosing_Element (Steps_Up => 1)) in A_Procedure_Body_Declaration .. A_Function_Body_Declaration or else Declaration_Kind (Get_Enclosing_Element (Steps_Up => 1)) = A_Task_Body_Declaration or else Statement_Kind (Get_Enclosing_Element (Steps_Up => 1)) = A_Block_Statement) then State.Detected := not Is_Handled (Exc => Element, By => Get_Handlers (Get_Enclosing_Element (Steps_Up => 1))); if Statement_Kind (Get_Enclosing_Element (Steps_Up => 1)) = A_Block_Statement then State.Diagnosis := 2; else State.Diagnosis := 1; end if; end if; -- Second part of the rule - potential propagation of a local exception -- outside its visibility if Statement_Kind (Element) = A_Raise_Statement then Handler := Get_Enclosing_Element (Step_Up); while Element_Kind (Handler) in A_Statement .. A_Path loop Step_Up := Step_Up + 1; Handler := Get_Enclosing_Element (Step_Up); end loop; Frame := Get_Enclosing_Element (Steps_Up => Step_Up + 1); if Element_Kind (Handler) = An_Exception_Handler and then (Declaration_Kind (Frame) in A_Procedure_Body_Declaration .. A_Function_Body_Declaration or else Declaration_Kind (Frame) = A_Task_Body_Declaration or else Statement_Kind (Frame) = A_Block_Statement) then -- Two different cases, depending if the raise statement contains -- an exception name Raised_Exc := Raised_Exception (Element); if Is_Nil (Raised_Exc) then declare Handled_Excs : constant Asis.Element_List := Exception_Choices (Handler); begin for J in Handled_Excs'Range loop if Definition_Kind (Handled_Excs (J)) = An_Others_Choice then exit; end if; Handled_Exc := Enclosing_Element (Get_Name_Definition (Handled_Excs (J))); if Is_Equal (Enclosing_Element (Handled_Exc), Frame) then State.Detected := True; State.Diagnosis := 3; State.Diag_Params := Enter_String ("%1%" & Element_Span (Handled_Exc).First_Line'Img); exit; end if; end loop; end; else Raised_Exc := Enclosing_Element (Get_Name_Definition (Raised_Exc)); if Is_Equal (Enclosing_Element (Raised_Exc), Frame) then State.Detected := True; State.Diagnosis := 3; State.Diag_Params := Enter_String ("%1%" & Element_Span (Raised_Exc).First_Line'Img); end if; end if; end if; end if; end Rule_Check_Pre_Op; ------------------------------------------------ -- XML_Rule_Help_Tip (Non_Visible_Exceptions) -- ------------------------------------------------ procedure XML_Rule_Help_Tip (Rule : Non_Visible_Exceptions_Rule_Type; Level : Natural) is pragma Unreferenced (Rule); begin Info_No_EOL (Level * Ident_String & ""); Info ("Flag constructs leading to the possibility of propagating an"); Info ("exception out of the scope in which the exception is declared."); Info ("Two cases are detected:"); Info ("* An exception declaration in a subprogram body, task body"); Info ("or block statement is flagged if the body or statement does not"); Info ("contain a handler for that exception or a handler with an "); Info ("others choice."); Info ("* A raise statement in an exception handler of a subprogram"); Info ("body, task body or block statement is flagged if it (re)raises"); Info ("a locally declared exception. This may occur under the"); Info ("following circumstances:"); Info (" - it explicitly raises a locally declared exception, or"); Info (" - it does not specify an exception name (i.e., it is simply"); Info ("raise;) and the enclosing handler contains a locally declared"); Info ("exception in its exception choices."); Info ("Renamings of local exceptions are not flagged."); end XML_Rule_Help_Tip; ---------------------- -- Numeric_Literals -- ---------------------- -------------------------------------- -- Annotate_Rule (Numeric_Literals) -- -------------------------------------- overriding function Annotate_Rule (Rule : Numeric_Literals_Rule_Type; Var : Diagnosis_Variant := 0) return String is pragma Unreferenced (Var); Result : String_Access; Tmp : String_Access; Is_First_Par : Boolean := True; begin if not Gnatcheck.Options.Mapping_Mode then return ""; end if; if Has_Synonym (Rule) then return " [" & Rule_Synonym (Rule) & "]"; end if; Result := new String'(" [" & Rule_Name (Rule)); case Rule.Up_To is when -1 => Tmp := new String'(Result.all); Free (Result); Result := new String'(Tmp.all & ":All"); Is_First_Par := False; when 1 => null; when others => Tmp := new String'(Result.all); Free (Result); Result := new String'(Tmp.all & ":" & Image (Rule.Up_To)); Is_First_Par := False; end case; Free (Tmp); if Rule.Statements_Only then Tmp := new String'(Result.all); Free (Result); Result := new String'( Tmp.all & (if Is_First_Par then ':' else ',') & "Statements_Only"); Free (Tmp); end if; declare Final_Res : constant String := Result.all & "]"; begin Free (Result); return Final_Res; end; end Annotate_Rule; ---------------------------------- -- Init_Rule (Numeric_Literals) -- ---------------------------------- procedure Init_Rule (Rule : in out Numeric_Literals_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Numeric_Literals"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("numeric literals"); Rule.Diagnosis := new String'("numeric literal (%1%) outside a " & "constant declaration"); end Init_Rule; ----------------------------------------------- -- Process_Rule_Parameter (Numeric_Literals) -- ----------------------------------------------- procedure Process_Rule_Parameter (Rule : in out Numeric_Literals_Rule_Type; Param : String; Enable : Boolean; Defined_At : String) is Needs_Redefinition_Warning : Boolean := False; Rule_Settings_Redefined : Boolean := False; begin if Param = "" then if Enable then Rule.Rule_State := Enabled; else Rule.Rule_State := Disabled; -- Restore defaults: Rule.Up_To := 1; Rule.Statements_Only := False; Rule.Defined_At := Nil_String_Loc; end if; return; end if; if Enable then if Gnatcheck.Options.Check_Param_Redefinition and then Rule.Rule_State = Enabled then Needs_Redefinition_Warning := True; end if; Rule.Rule_State := Enabled; if To_Lower (Param) = "all" then if Needs_Redefinition_Warning and then Rule.Up_To /= -1 then Rule_Settings_Redefined := True; end if; Rule.Up_To := -1; elsif To_Lower (Param) = "statements_only" then if Needs_Redefinition_Warning and then not Rule.Statements_Only then Rule_Settings_Redefined := True; end if; Rule.Statements_Only := True; else begin if Needs_Redefinition_Warning and then Rule.Up_To /= Natural'Value (Param) then Rule_Settings_Redefined := True; end if; Rule.Up_To := Natural'Value (Param); exception when Constraint_Error => Error ("(" & Rule.Name.all & ") wrong parameter: " & Param); end; end if; if Rule_Settings_Redefined then Error ("redefining at " & (if Defined_At = "" then "command line" else Defined_At) & " settings for rule " & Rule.Name.all & " defined at " & (if Rule.Defined_At = Nil_String_Loc then "command line" else Get_String (Rule.Defined_At))); end if; Rule.Defined_At := Enter_String (Defined_At); else Error ("(" & Rule.Name.all & ") no parameter allowed for -R"); end if; end Process_Rule_Parameter; ------------------------------------------ -- Rule_Check_Pre_Op (Numeric_Literals) -- ------------------------------------------ procedure Rule_Check_Pre_Op (Rule : in out Numeric_Literals_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Control); pragma Unmodified (Rule); Arg_Kind : constant Expression_Kinds := Expression_Kind (Element); Integer_Literal_Value : Natural; begin if Arg_Kind in An_Integer_Literal .. A_Real_Literal then if Arg_Kind = An_Integer_Literal and then Rule.Up_To > 0 then begin Integer_Literal_Value := Natural'Value (To_String (Value_Image (Element))); exception when Constraint_Error => -- The value is definitely too big to be an exception for -- this rule! Integer_Literal_Value := Natural'Last; end; if Integer_Literal_Value <= Rule.Up_To then -- Literal is too small to be flagged return; end if; end if; declare Encl_El : Asis.Element := Get_Enclosing_Element; Old_Encl_El : Asis.Element := Element; Step_Up : Elmt_Idx := 0; begin while Element_Kind (Encl_El) = An_Expression or else Path_Kind (Encl_El) in A_Case_Expression_Path .. An_Else_Expression_Path or else (Element_Kind (Encl_El) = An_Association and then Association_Kind (Encl_El) /= An_Array_Component_Association) or else (Association_Kind (Encl_El) = An_Array_Component_Association and then Is_Equal (Old_Encl_El, Component_Expression (Encl_El))) or else (Definition_Kind (Encl_El) = A_Discrete_Subtype_Definition and then Declaration_Kind (Get_Enclosing_Element (Step_Up + 1)) = A_Loop_Parameter_Specification) loop Step_Up := Step_Up + 1; Old_Encl_El := Encl_El; Encl_El := Get_Enclosing_Element (Step_Up); end loop; if not (Declaration_Kind (Encl_El) = A_Constant_Declaration or else Declaration_Kind (Encl_El) in An_Integer_Number_Declaration .. A_Real_Number_Declaration or else Clause_Kind (Encl_El) in A_Representation_Clause | A_Component_Clause or else Definition_Kind (Encl_El) = An_Aspect_Specification or else (Discrete_Range_Kind (Encl_El) = A_Discrete_Simple_Expression_Range and then Clause_Kind (Get_Enclosing_Element (Step_Up + 1)) = A_Component_Clause)) then if Rule.Statements_Only then State.Detected := Element_Kind (Encl_El) in A_Statement .. A_Path or else Declaration_Kind (Encl_El) = A_Loop_Parameter_Specification; else State.Detected := True; end if; end if; end; if State.Detected then State.Diag_Params := Enter_String ("%1%" & To_String (Value_Image (Element))); end if; end if; end Rule_Check_Pre_Op; ------------------------------------------------- -- XML_Rule_Parameters_Help (Numeric_Literals) -- ------------------------------------------------- procedure XML_Rule_Help (Rule : Numeric_Literals_Rule_Type; Level : Natural) is begin -- Info (Level * Ident_String & -- ""); Info (Level * Ident_String & ""); Info (Level * Ident_String & ""); -- Info (Level * Ident_String & -- ""); end XML_Rule_Help; -------------------------- -- OTHERS_In_Aggregates -- -------------------------- -------------------------------------- -- Init_Rule (OTHERS_In_Aggregates) -- -------------------------------------- procedure Init_Rule (Rule : in out OTHERS_In_Aggregates_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("OTHERS_In_Aggregates"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("OTHERS choices in aggregates"); Rule.Diagnosis := new String'("OTHERS choice in aggregate"); end Init_Rule; ---------------------------------------------- -- Rule_Check_Pre_Op (OTHERS_In_Aggregates) -- ---------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out OTHERS_In_Aggregates_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Aggregate : Asis.Element; begin if Definition_Kind (Element) = An_Others_Choice then Aggregate := Get_Enclosing_Element (Steps_Up => 1); case Expression_Kind (Aggregate) is when An_Extension_Aggregate => State.Detected := True; when A_Record_Aggregate | A_Positional_Array_Aggregate | A_Named_Array_Aggregate => declare Associations : constant Asis.Element_List := Get_Associations (Aggregate); begin if Associations'Length >= 3 then State.Detected := True; elsif Associations'Length = 2 then declare Choices : constant Asis.Element_List := Get_Choices (Associations (Associations'First)); begin if Choices'Length >= 2 then State.Detected := True; elsif Choices'Length = 1 then if Definition_Kind (Choices (Choices'First)) = A_Discrete_Range then State.Detected := True; end if; end if; end; end if; end; when others => null; end case; end if; end Rule_Check_Pre_Op; ------------------------------- -- OTHERS_In_CASE_Statements -- ------------------------------- ------------------------------------------- -- Init_Rule (OTHERS_In_CASE_Statements) -- ------------------------------------------- procedure Init_Rule (Rule : in out OTHERS_In_CASE_Statements_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("OTHERS_In_CASE_Statements"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("OTHERS choices in case statements"); Rule.Diagnosis := new String'("OTHERS choice in case statement"); end Init_Rule; --------------------------------------------------- -- Rule_Check_Pre_Op (OTHERS_In_CASE_Statements) -- --------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out OTHERS_In_CASE_Statements_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); begin if Definition_Kind (Element) = An_Others_Choice and then Path_Kind (Get_Enclosing_Element) = A_Case_Path then State.Detected := True; end if; end Rule_Check_Pre_Op; ---------------------------------- -- OTHERS_In_Exception_Handlers -- ---------------------------------- ---------------------------------------------- -- Init_Rule (OTHERS_In_Exception_Handlers) -- ---------------------------------------------- procedure Init_Rule (Rule : in out OTHERS_In_Exception_Handlers_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("OTHERS_In_Exception_Handlers"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("OTHERS choices in exception handlers"); Rule.Diagnosis := new String'("OTHERS choice in exception handler"); end Init_Rule; ------------------------------------------------------ -- Rule_Check_Pre_Op (OTHERS_In_Exception_Handlers) -- ------------------------------------------------------ procedure Rule_Check_Pre_Op (Rule : in out OTHERS_In_Exception_Handlers_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); begin if Definition_Kind (Element) = An_Others_Choice and then Element_Kind (Get_Enclosing_Element) = An_Exception_Handler then State.Detected := True; end if; end Rule_Check_Pre_Op; -------------------------------------- -- Overly_Nested_Control_Structures -- -------------------------------------- -------------------------------------------------- -- Init_Rule (Overly_Nested_Control_Structures) -- -------------------------------------------------- procedure Init_Rule (Rule : in out Overly_Nested_Control_Structures_Rule_Type) is begin Init_Rule (One_Integer_Parameter_Rule_Template (Rule)); Rule.Name := new String'("Overly_Nested_Control_Structures"); Rule.Synonym := new String'("Control_Structure_Nesting"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("deep nesting level of " & "control structures"); Rule.Diagnosis := new String'("nesting level of control structures " & "too deep"); end Init_Rule; ---------------------------------------------------------- -- Rule_Check_Pre_Op (Overly_Nested_Control_Structures) -- ---------------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Overly_Nested_Control_Structures_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Control); pragma Unmodified (Rule); Nesting_Level : Natural := 0; Step_Up : Elmt_Idx := 0; Encl_El : Asis.Element; begin if Is_Control_Structure (Element) then Encl_El := Get_Enclosing_Element (Step_Up); while Element_Kind (Encl_El) in A_Statement .. A_Path loop if Is_Control_Structure (Encl_El) then Nesting_Level := Nesting_Level + 1; if Nesting_Level > Rule.Rule_Limit then State.Detected := True; exit; end if; end if; Step_Up := Step_Up + 1; Encl_El := Get_Enclosing_Element (Step_Up); end loop; end if; end Rule_Check_Pre_Op; ----------------------------- -- Parameters_Out_Of_Order -- ----------------------------- ----------------------------------------- -- Init_Rule (Parameters_Out_Of_Order) -- ----------------------------------------- procedure Init_Rule (Rule : in out Parameters_Out_Of_Order_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Parameters_Out_Of_Order"); Rule.Synonym := new String'("Parameter_Mode_Ordering"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("formal parameters ordering"); Rule.Diagnosis := new String'( "#1#parameter %1% of mode %2% precedes parameter %3% of mode %4%" & "#2#parameter %1% with default initialization precedes " & "parameter %2% without it"); end Init_Rule; ------------------------------------------------- -- Rule_Check_Pre_Op (Parameters_Out_Of_Order) -- ------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Parameters_Out_Of_Order_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Arg_Kind : constant Declaration_Kinds := Declaration_Kind (Element); Check_Profile : Boolean := False; begin case Arg_Kind is when A_Procedure_Declaration | A_Function_Declaration | A_Null_Procedure_Declaration | An_Entry_Declaration | A_Generic_Procedure_Declaration | A_Generic_Function_Declaration | A_Formal_Procedure_Declaration | A_Formal_Function_Declaration => Check_Profile := True; when A_Procedure_Body_Declaration | A_Function_Body_Declaration | A_Procedure_Body_Stub | A_Function_Body_Stub => Check_Profile := Acts_As_Spec (Element); when others => null; end case; if Check_Profile then declare Params : constant Asis.Element_List := Parameter_Profile (Element); Prev_Mode : Mode_Kinds; Succ_Mode : Mode_Kinds; Prev_Name : Asis.Element; Succ_Name : Asis.Element; Prev_Par_Has_Default_Expr : Boolean; begin if Params'Length > 1 then Prev_Mode := Mode_Kind (Params (Params'First)); Prev_Par_Has_Default_Expr := not Is_Nil (Initialization_Expression (Params (Params'First))); for J in Params'First + 1 .. Params'Last loop -- First, check if the mode ordering is right, that is -- IN -> IN OUT -> OUT -- This check does not make sense for functions: if not (Arg_Kind = A_Function_Declaration or else Arg_Kind = A_Generic_Function_Declaration or else Arg_Kind = A_Formal_Function_Declaration or else Arg_Kind = A_Function_Body_Stub) then Succ_Mode := Mode_Kind (Params (J)); case Prev_Mode is when An_In_Out_Mode => -- IN OUT -> IN is a violation: if Succ_Mode in A_Default_In_Mode .. An_In_Mode then Prev_Name := First_Name (Params (J - 1)); Succ_Name := First_Name (Params (J)); State.Detected := True; State.Diagnosis := 1; State.Diag_Params := Enter_String ( "%1%" & To_String (Defining_Name_Image (Prev_Name)) & "%2%" & "IN OUT" & "%3%" & To_String (Defining_Name_Image (Succ_Name)) & "%4%" & "IN"); exit; end if; when An_Out_Mode => if Succ_Mode in A_Default_In_Mode .. An_In_Mode then -- OUT -> IN is a violation: Prev_Name := First_Name (Params (J - 1)); Succ_Name := First_Name (Params (J)); State.Detected := True; State.Diagnosis := 1; State.Diag_Params := Enter_String ( "%1%" & To_String (Defining_Name_Image (Prev_Name)) & "%2%" & "OUT" & "%3%" & To_String (Defining_Name_Image (Succ_Name)) & "%4%" & "IN"); exit; elsif Succ_Mode = An_In_Out_Mode then -- OUT -> IN OUT is a violation: Prev_Name := First_Name (Params (J - 1)); Succ_Name := First_Name (Params (J)); State.Detected := True; State.Diagnosis := 1; State.Diag_Params := Enter_String ( "%1%" & To_String (Defining_Name_Image (Prev_Name)) & "%2%" & "OUT" & "%3%" & To_String (Defining_Name_Image (Succ_Name)) & "%4%" & "IN OUT"); exit; end if; when A_Default_In_Mode .. An_In_Mode => -- Any mode can follow IN mode null; when others => pragma Assert (False); null; end case; end if; -- Now check that IN parameters with default initialization -- go last in the group of IN parameters: if Succ_Mode in A_Default_In_Mode .. An_In_Mode and then Prev_Mode in A_Default_In_Mode .. An_In_Mode then if Prev_Par_Has_Default_Expr then if Is_Nil (Initialization_Expression (Params (J))) then Prev_Name := First_Name (Params (J - 1)); Succ_Name := First_Name (Params (J)); State.Detected := True; State.Diagnosis := 2; State.Diag_Params := Enter_String ( "%1%" & To_String (Defining_Name_Image (Prev_Name)) & "%2%" & To_String (Defining_Name_Image (Succ_Name))); exit; end if; else Prev_Par_Has_Default_Expr := not Is_Nil (Initialization_Expression (Params (J))); end if; end if; Prev_Mode := Succ_Mode; end loop; end if; end; end if; end Rule_Check_Pre_Op; --------------------------------------------------------- -- Positional_Actuals_For_Defaulted_Generic_Parameters -- --------------------------------------------------------- --------------------------------------------------------------------- -- Init_Rule (Positional_Actuals_For_Defaulted_Generic_Parameters) -- --------------------------------------------------------------------- procedure Init_Rule (Rule : in out Positional_Actuals_For_Defaulted_Generic_Parameters_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Positional_Actuals_For_Defaulted_Generic_Parameters"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("positional generic actuals for " & "defaulted generic parameters"); Rule.Diagnosis := new String'("use named notation when passing " & "actual to defaulted generic parameter"); end Init_Rule; ---------------------------------------------------------------------------- -- Rule_Check_Pre_Op(Positional_Actuals_For_Defaulted_Generic_Parameters) -- ---------------------------------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Positional_Actuals_For_Defaulted_Generic_Parameters_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Gen_Decl : Asis.Element; begin if Association_Kind (Element) = A_Generic_Association and then Is_Nil (Formal_Parameter (Element)) then -- Compute the corresponding generic declaration. Gen_Decl := Generic_Unit_Name (Get_Enclosing_Element); Gen_Decl := Normalize_Reference (Gen_Decl); Gen_Decl := Corresponding_Name_Declaration (Gen_Decl); if Declaration_Kind (Gen_Decl) in A_Generic_Package_Renaming_Declaration .. A_Generic_Function_Renaming_Declaration then Gen_Decl := Corresponding_Base_Entity (Gen_Decl); Gen_Decl := Normalize_Reference (Gen_Decl); Gen_Decl := Corresponding_Name_Declaration (Gen_Decl); end if; declare Formal_Params : constant Asis.Element_List := Generic_Formal_Part (Gen_Decl); Actuals : constant Asis.Element_List := Generic_Actual_Part (Get_Enclosing_Element); Move_Act : Natural := 0; Move_Form : Natural := 0; Form_Idx : Natural := 0; begin for J in Actuals'Range loop if Is_Equal (Actuals (J), Element) then exit; end if; Move_Act := Move_Act + 1; end loop; -- Now Move_Act gives us a number of the actual parameter in -- question in the call minus 1. This parameter is in positional -- association, so we have to count to the corresponding generic -- formal. The problem here is that we can have more than one -- formal parameter declared in one parameter specification. for J in Formal_Params'Range loop if Element_Kind (Formal_Params (J)) /= A_Clause then Move_Form := Move_Form + Names (Formal_Params (J))'Length; if Move_Form > Move_Act then Form_Idx := J; exit; end if; end if; end loop; case Declaration_Kind (Formal_Params (Form_Idx)) is when A_Formal_Object_Declaration => State.Detected := not Is_Nil (Initialization_Expression (Formal_Params (Form_Idx))); when A_Formal_Procedure_Declaration | A_Formal_Function_Declaration => State.Detected := Default_Kind (Formal_Params (Form_Idx)) /= A_Nil_Default; when others => null; end case; end; end if; end Rule_Check_Pre_Op; ------------------------------------------------- -- Positional_Actuals_For_Defaulted_Parameters -- ------------------------------------------------- ------------------------------------------------------------- -- Init_Rule (Positional_Actuals_For_Defaulted_Parameters) -- ------------------------------------------------------------- procedure Init_Rule (Rule : in out Positional_Actuals_For_Defaulted_Parameters_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Positional_Actuals_For_Defaulted_Parameters"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("positional actuals for " & "defaulted parameters"); Rule.Diagnosis := new String'("use named notation when passing " & "actual to defaulted parameter"); end Init_Rule; --------------------------------------------------------------------- -- Rule_Check_Pre_Op (Positional_Actuals_For_Defaulted_Parameters) -- --------------------------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Positional_Actuals_For_Defaulted_Parameters_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); begin if Association_Kind (Element) = A_Parameter_Association and then Is_Nil (Formal_Parameter (Element)) and then not Is_Call_To_Operator_Function (Get_Enclosing_Element) and then not Is_Call_To_Attribute_Subprogram (Get_Enclosing_Element) then if not Is_Nil (Initialization_Expression (Get_Parameter_Declaration (Element))) then State.Detected := True; end if; end if; end Rule_Check_Pre_Op; --------------------------- -- Positional_Components -- --------------------------- --------------------------------------- -- Init_Rule (Positional_Components) -- --------------------------------------- procedure Init_Rule (Rule : in out Positional_Components_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Positional_Components"); Rule.Synonym := new String'("Positional_Component_Associations"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("positional components associations " & "in aggregates"); Rule.Diagnosis := new String'("aggregate with a positional " & "component association"); end Init_Rule; ----------------------------------------------- -- Rule_Check_Pre_Op (Positional_Components) -- ----------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Positional_Components_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); begin case Expression_Kind (Element) is when A_Record_Aggregate | An_Extension_Aggregate => State.Detected := Has_Positional_Association (Element); when A_Positional_Array_Aggregate => State.Detected := True; when others => null; end case; end Rule_Check_Pre_Op; ----------------------------------- -- Positional_Generic_Parameters -- ----------------------------------- ----------------------------------------------- -- Init_Rule (Positional_Generic_Parameters) -- ----------------------------------------------- procedure Init_Rule (Rule : in out Positional_Generic_Parameters_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Positional_Generic_Parameters"); Rule.Synonym := new String'("Positional_Generic_Associations"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("positional generic associations"); Rule.Diagnosis := new String'("positional generic association"); end Init_Rule; ------------------------------------------------------- -- Rule_Check_Pre_Op (Positional_Generic_Parameters) -- ------------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Positional_Generic_Parameters_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); begin if Association_Kind (Element) = A_Generic_Association and then Is_Nil (Formal_Parameter (Element)) then if not Has_One_Parameter (Get_Enclosing_Element) then State.Detected := True; end if; end if; end Rule_Check_Pre_Op; --------------------------- -- Positional_Parameters -- --------------------------- --------------------------------------------------------- -- Activate_In_Test_Mode (Unconstrained_Array_Returns) -- --------------------------------------------------------- overriding procedure Activate_In_Test_Mode (Rule : in out Positional_Parameters_Rule_Type) is begin Process_Rule_Parameter (Rule => Rule, Param => "All", Enable => True, Defined_At => ""); end Activate_In_Test_Mode; -------------------------------------------------- -- Exception_Name (Unconstrained_Array_Returns) -- -------------------------------------------------- function Exception_Name (Rule : Positional_Parameters_Rule_Type; Exc_Index : Exception_Index) return String is pragma Unreferenced (Rule); begin case Exc_Index is when 1 => return "All"; when others => return ""; end case; end Exception_Name; ---------------------------------------------------- -- Exception_Number (Unconstrained_Array_Returns) -- ---------------------------------------------------- function Exception_Number (Rule : Positional_Parameters_Rule_Type; Exc_Name : String) return Exception_Numbers is pragma Unreferenced (Rule); Result : Exception_Numbers := Not_An_Exception; Normalized_Exc_Name : constant String := To_Lower (Exc_Name); begin if Normalized_Exc_Name = "all" then Result := 1; end if; return Result; end Exception_Number; --------------------------------------- -- Init_Rule (Positional_Parameters) -- --------------------------------------- overriding procedure Init_Rule (Rule : in out Positional_Parameters_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Positional_Parameters"); Rule.Synonym := new String'("Positional_Parameter_Associations"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("positional associations in " & "subprogram and entry calls"); Rule.Diagnosis := new String'("positional parameter association"); end Init_Rule; ----------------------------------------------- -- Rule_Check_Pre_Op (Positional_Parameters) -- ----------------------------------------------- overriding procedure Rule_Check_Pre_Op (Rule : in out Positional_Parameters_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Control); begin if Association_Kind (Element) = A_Parameter_Association and then Is_Nil (Formal_Parameter (Element)) then -- Now - check for exceptions: if not ( -- unconditional exceptions Is_Call_To_Operator_Function (Get_Enclosing_Element) or else Is_Call_To_Attribute_Subprogram (Get_Enclosing_Element) -- exceptions that depends on parameter value or else (not Rule.Exceptions (1) and then Has_One_Parameter (Get_Enclosing_Element)) or else (Is_Prefix_Notation (Get_Enclosing_Element) and then Is_Prefix_Notation_Exception (Element, not Rule.Exceptions (1)))) then State.Detected := True; end if; end if; end Rule_Check_Pre_Op; ----------------------------------- -- Predefined_Numeric_Types_Rule -- ----------------------------------- ----------------------------------------- -- Init_Rule (Predefined_Numeric_Types -- ----------------------------------------- procedure Init_Rule (Rule : in out Predefined_Numeric_Types_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Predefined_Numeric_Types"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("explicit references to predefined " & "numeric subtypes"); Rule.Diagnosis := new String'("explicit reference to predefined " & "numeric subtype"); end Init_Rule; ------------------------------------------------- -- Rule_Check_Pre_Op (Predefined_Numeric_Types -- ------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Predefined_Numeric_Types_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); begin if Expression_Kind (Element) = An_Identifier and then Is_Ref_To_Standard_Num_Subtype (Element) then State.Detected := True; end if; end Rule_Check_Pre_Op; --------------------------------- -- Raising_External_Exceptions -- --------------------------------- --------------------------------------------- -- Init_Rule (Raising_External_Exceptions) -- --------------------------------------------- procedure Init_Rule (Rule : in out Raising_External_Exceptions_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Raising_External_Exceptions"); Rule.Synonym := new String'("Visible_Exceptions"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("visibility of exceptions raised by " & "routines declared in library package"); Rule.Diagnosis := new String'("raised exception is not declared in " & "visible part of enclosing library " & "package"); end Init_Rule; ----------------------------------------------------- -- Rule_Check_Pre_Op (Raising_External_Exceptions) -- ----------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Raising_External_Exceptions_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Raised_Exc : Asis.Element; Encl_CU : Asis.Compilation_Unit := Enclosing_Compilation_Unit (Element); begin if Statement_Kind (Element) = A_Raise_Statement and then (Unit_Kind (Encl_CU) = A_Package or else Unit_Kind (Encl_CU) = A_Generic_Package or else Unit_Kind (Encl_CU) = A_Package_Body) then Raised_Exc := Raised_Exception (Element); if not Is_Nil (Raised_Exc) then Raised_Exc := Normalize_Reference (Raised_Exc); Raised_Exc := Corresponding_Name_Definition (Raised_Exc); -- Note, that we do not unwind renamings, that is, if Raised_Exc -- is a renaming of a Standard exception that takes place in -- another package, we consider this as a rule violation. if not Is_From_Standard (Raised_Exc) then if Unit_Kind (Encl_CU) = A_Package_Body then Encl_CU := Corresponding_Declaration (Encl_CU); if not Is_Equal (Enclosing_Compilation_Unit (Raised_Exc), Encl_CU) then State.Detected := True; else State.Detected := not Is_Public (Raised_Exc); end if; end if; end if; end if; end if; end Rule_Check_Pre_Op; ----------------------------------- -- Raising_Predefined_Exceptions -- ----------------------------------- --------------------------------------- -- Init_Rule (Raising_Predefined_Exceptions) -- --------------------------------------- procedure Init_Rule (Rule : in out Raising_Predefined_Exceptions_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Raising_Predefined_Exceptions"); Rule.Synonym := new String'("Predefined_Exceptions"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("explicit raise of predefined " & "exceptions"); Rule.Diagnosis := new String'("explicit raise of a predefined " & "exception"); end Init_Rule; ------------------------------------------------------- -- Rule_Check_Pre_Op (Raising_Predefined_Exceptions) -- ------------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Raising_Predefined_Exceptions_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Raised_Exc : Asis.Element; begin if Statement_Kind (Element) = A_Raise_Statement then Raised_Exc := Raised_Exception (Element); if not Is_Nil (Raised_Exc) then Raised_Exc := Normalize_Reference (Raised_Exc); Raised_Exc := Corresponding_Name_Declaration (Raised_Exc); if Declaration_Kind (Raised_Exc) = An_Exception_Renaming_Declaration then Raised_Exc := Corresponding_Base_Entity (Raised_Exc); Raised_Exc := Normalize_Reference (Raised_Exc); Raised_Exc := Corresponding_Name_Declaration (Raised_Exc); end if; State.Detected := Is_From_Standard (Raised_Exc); end if; end if; end Rule_Check_Pre_Op; ------------------------------- -- Unassigned_OUT_Parameters -- ------------------------------- -------------------------------------------------------- -- Data structures and local subprograms for the rule -- -------------------------------------------------------- type Formal_Parameter_Record is record Par_Def_Name : Asis.Element; -- Defining name of the parameter Assigned : Boolean := False; -- Flag indicating if this parameter has got a value. end record; package OUT_Parameters_Table is new GNAT.Table (Table_Component_Type => Formal_Parameter_Record, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 20, Table_Increment => 50, Table_Name => "OUT parameters"); procedure Set_OUT_Parameters (El : Asis.Element); -- Supposing that El is a procedure body declaration, sets in -- OUT_Parameters_Table the list of OUT parameters of this procedure function Get_Bad_Parameter_List return String_Loc; -- Forms from the content of OUT_Parameters_Table the list of the bad -- parameter names to be placed in the diagnosis and returns the -- corresponding pointer in the string table. Check_Handler : Boolean; -- We need this global flag to decide if we have to traverse exceptions -- handlers. First_Body : Boolean; -- We need this flag to make the difference between the procedure body -- declaration from which the traversal starts (we have to analyze it), and -- all the other declarations, that should be skipped during the traversal procedure Check_Reference (Element : Asis.Element; Control : in out Traverse_Control; State : in out Natural); -- Checks if the argument is a reference to OUT parameter that sets its -- value. If such a reference is detected, updates parameter records in -- OUT_Parameters_Table. Decreases State each time when detects that one -- more OUT parameter gets a value. terminate the traversal when all the -- parameters have got values (State gets the value 0) procedure No_Opeation (Element : Asis.Element; Control : in out Traverse_Control; State : in out Natural); -- Does nothing. procedure Check_References is new Asis.Iterator.Traverse_Element (Pre_Operation => Check_Reference, Post_Operation => No_Opeation, State_Information => Natural); ------------------------------------------------- -- Check_Reference (Unassigned_OUT_Parameters) -- ------------------------------------------------- procedure Check_Reference (Element : Asis.Element; Control : in out Traverse_Control; State : in out Natural) is Tmp_El : Asis.Element; Old_Enclosing : Asis.Element; Par_Idx : Natural; begin -- If we are here, State cannot be 0, so we have to do the job,,, case Flat_Element_Kind (Element) is when Flat_Declaration_Kinds => if First_Body then First_Body := False; else Control := Abandon_Children; end if; when An_Exception_Handler => if Declaration_Kind (Enclosing_Element (Element)) = A_Procedure_Body_Declaration and then Check_Handler then -- If we are here, the only possibility is that we are checking -- an exception handler from some procedure body. null; else -- If we are here, we are in some "inner" exception handler -- (note, that we skip all the declaration except the procedure -- body declaration for which the traversing is started). We -- just skip it) Control := Abandon_Children; end if; when An_Identifier => Tmp_El := Get_Corresponding_Definition (Element); if Defining_Name_Kind (Tmp_El) = A_Defining_Identifier then Tmp_El := Corresponding_Body_Parameter_Definition (Tmp_El); end if; if Defining_Name_Kind (Tmp_El) = A_Defining_Identifier then Par_Idx := 0; for J in 1 .. OUT_Parameters_Table.Last loop if Is_Equal (Tmp_El, OUT_Parameters_Table.Table (J).Par_Def_Name) then Par_Idx := J; exit; end if; end loop; if Par_Idx > 0 and then not OUT_Parameters_Table.Table (Par_Idx).Assigned then -- And now we have to check if Element is in a position that -- can result in assigning a value to the corresponding OUT -- parameter Old_Enclosing := Element; Tmp_El := Enclosing_Element (Old_Enclosing); while Element_Kind (Tmp_El) = An_Expression loop if (Expression_Kind (Tmp_El) = An_Indexed_Component and then not Is_Equal (Old_Enclosing, Prefix (Tmp_El))) or else (Expression_Kind (Tmp_El) = An_Explicit_Dereference and then Is_Equal (Old_Enclosing, Prefix (Tmp_El))) then -- The first condition means that we have an index in -- an indexed component. The second condition means -- that we have a prefix of explicit dereference. In -- both cases the object in question cannot get -- a value exit; end if; Old_Enclosing := Tmp_El; Tmp_El := Enclosing_Element (Old_Enclosing); end loop; if Statement_Kind (Tmp_El) = An_Assignment_Statement and then Is_Equal (Old_Enclosing, Assignment_Variable_Name (Tmp_El)) then OUT_Parameters_Table.Table (Par_Idx).Assigned := True; State := State - 1; elsif Association_Kind (Tmp_El) = A_Parameter_Association then -- Here we have to check if it is an actual for OUT -- or IN OUT parameter -- ??? See pre-operation for -- Positional_Actuals_For_Defaulted_Parameters rule - -- there is definitely some duplication here! Old_Enclosing := Enclosing_Element (Tmp_El); if not (Expression_Kind (Old_Enclosing) = A_Function_Call or else Is_Call_To_Attribute_Subprogram (Old_Enclosing)) then Old_Enclosing := Get_Parameter_Declaration (Tmp_El); if Mode_Kind (Old_Enclosing) in An_Out_Mode .. An_In_Out_Mode then OUT_Parameters_Table.Table (Par_Idx).Assigned := True; State := State - 1; end if; end if; end if; end if; end if; when others => null; end case; if State = 0 then Control := Terminate_Immediately; end if; end Check_Reference; -------------------------------------------------------- -- Get_Bad_Parameter_List (Unassigned_OUT_Parameters) -- -------------------------------------------------------- function Get_Bad_Parameter_List return String_Loc is Str, Tmp_Str : String_Access; Result : String_Loc; begin for J in 1 .. OUT_Parameters_Table.Last loop if not OUT_Parameters_Table.Table (J).Assigned then if Tmp_Str = null then -- first parameter to report Str := new String'("%1%" & To_String (Defining_Name_Image (OUT_Parameters_Table.Table (J).Par_Def_Name))); else Free (Str); Str := new String'(Tmp_Str.all & ", " & To_String (Defining_Name_Image (OUT_Parameters_Table.Table (J).Par_Def_Name))); end if; Free (Tmp_Str); Tmp_Str := new String'(Str.all); end if; end loop; Result := Enter_String (Str.all & "%1%"); Free (Str); Free (Tmp_Str); return (Result); end Get_Bad_Parameter_List; ------------------------------------------- -- Init_Rule (Unassigned_OUT_Parameters) -- ------------------------------------------- procedure Init_Rule (Rule : in out Unassigned_OUT_Parameters_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Unassigned_OUT_Parameters"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("OUT parameters do not get values " & "in procedure bodies"); Rule.Diagnosis := new String'("#1#procedure body does not define " & "values for OUT parameters: %1%" & "#2#exception handler does not define " & "values for OUT parameters: %1%"); end Init_Rule; --------------------------------------------- -- No_Opeation (Unassigned_OUT_Parameters) -- --------------------------------------------- procedure No_Opeation (Element : Asis.Element; Control : in out Traverse_Control; State : in out Natural) is pragma Unreferenced (Element, Control, State); begin null; end No_Opeation; --------------------------------------------------- -- Rule_Check_Pre_Op (Unassigned_OUT_Parameters) -- --------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Unassigned_OUT_Parameters_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Get_Params_From : Asis.Element; Unassigned_Params : Natural; -- Unassigned_Params indicates the number of OUT parameters for that we -- do not know that they have got values Check_Ref_Control : Traverse_Control := Continue; begin if Declaration_Kind (Element) = A_Procedure_Body_Declaration or else (Element_Kind (Element) = An_Exception_Handler and then Declaration_Kind (Get_Enclosing_Element) = A_Procedure_Body_Declaration) then if Element_Kind (Element) = An_Exception_Handler then if Raises_Exception (Element) then return; end if; Get_Params_From := Get_Enclosing_Element; First_Body := False; Check_Handler := True; else Get_Params_From := Element; First_Body := True; Check_Handler := False; end if; OUT_Parameters_Table.Init; Set_OUT_Parameters (Get_Params_From); Unassigned_Params := OUT_Parameters_Table.Last; if Unassigned_Params > 0 then Check_References (Element, Check_Ref_Control, Unassigned_Params); if Unassigned_Params > 0 then State.Detected := True; if Declaration_Kind (Element) = A_Procedure_Body_Declaration then State.Diagnosis := 1; else State.Diagnosis := 2; end if; State.Diag_Params := Get_Bad_Parameter_List; end if; end if; end if; end Rule_Check_Pre_Op; ---------------------------------------------------- -- Set_OUT_Parameters (Unassigned_OUT_Parameters) -- ---------------------------------------------------- procedure Set_OUT_Parameters (El : Asis.Element) is Par_Specs : constant Asis.Element_List := Parameter_Profile (El); begin for J in Par_Specs'Range loop if Mode_Kind (Par_Specs (J)) = An_Out_Mode then declare Nms : constant Asis.Element_List := Names (Par_Specs (J)); begin for K in Nms'Range loop OUT_Parameters_Table.Append ((Par_Def_Name => Nms (K), Assigned => False)); end loop; end; end if; end loop; end Set_OUT_Parameters; ----------------------------------------- -- Uncommented_BEGIN_In_Package_Bodies -- ----------------------------------------- ----------------------------------------------------- -- Init_Rule (Uncommented_BEGIN_In_Package_Bodies) -- ----------------------------------------------------- procedure Init_Rule (Rule : in out Uncommented_BEGIN_In_Package_Bodies_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Uncommented_BEGIN_In_Package_Bodies"); Rule.Synonym := new String'("Non_Marked_BEGIN_In_Package_Body"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("BEGIN keywords in package bodies " & "non-marked with " & "comment with package name"); Rule.Diagnosis := new String'("#1#mark BEGIN with package name (%1%)" & "#2#place BEGIN in package body " & "on separate line"); end Init_Rule; ------------------------------------------------------------- -- Rule_Check_Pre_Op (Uncommented_BEGIN_In_Package_Bodies) -- ------------------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Uncommented_BEGIN_In_Package_Bodies_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); begin if Declaration_Kind (Element) = A_Package_Body_Declaration and then Has_Statements_And_Decls (Element) then declare Dcls : constant Asis.Element_List := Body_Declarative_Items (Element, Include_Pragmas => True); Last_Dcl : constant Positive := Dcls'Last; Stmts : constant Asis.Element_List := Body_Statements (Element, Include_Pragmas => True); First_Stmt : constant Positive := Stmts'First; LList : constant Line_List := Lines (Element => Element, First_Line => Element_Span (Dcls (Last_Dcl)).Last_Line, Last_Line => Element_Span (Stmts (First_Stmt)).First_Line); Begin_Line : Line_Number_Positive; Begin_Start : Character_Position; Begin_Found : Boolean := False; begin -- First, check a most reasonable case - if we have BEGIN on a -- separate line between the last declaration and the first -- statement for J in LList'First + 1 .. LList'Last - 1 loop -- In this range, the only word the non-comment image of a -- line can contain is 'BEGIN' if To_Lower (ASIS_Trim (To_String (Non_Comment_Image (LList (J))))) = "begin" then Begin_Found := True; declare Img : constant Program_Text := Non_Comment_Image (LList (J)); begin Begin_Start := 1; for J in Img'Range loop exit when Img (J) = 'b' or else Img (J) = 'B'; Begin_Start := Begin_Start + 1; end loop; end; Begin_Line := J; exit; end if; end loop; if Begin_Found then declare Img : constant String := ASIS_Trim (To_String (Comment_Image (LList (Begin_Line)))); Firts_Idx : Natural := Img'First; Last_Idx : Natural := Img'Last; begin if Img'Length = 0 then State.Detected := True; else Firts_Idx := Img'First + 2; while Is_White_Space (Img (Firts_Idx)) and then Firts_Idx <= Last_Idx loop Firts_Idx := Firts_Idx + 1; end loop; for J in Firts_Idx + 1 .. Last_Idx loop if Is_White_Space (Img (J)) then Last_Idx := J - 1; exit; end if; end loop; State.Detected := To_Lower (Img (Firts_Idx .. Last_Idx)) /= To_Lower (To_String (Defining_Name_Image (First_Name (Element)))); State.Line := Begin_Line; State.Column := Begin_Start; end if; end; if State.Detected then State.Diagnosis := 1; end if; else -- Pathological case - BEGIN in the same line as either the -- last declaration or the first statement State.Detected := True; State.Diagnosis := 2; State.Line := Element_Span (Stmts (First_Stmt)).First_Line; State.Column := 1; end if; if State.Detected and then State.Diagnosis = 1 then State.Diag_Params := Enter_String ("%1%" & To_String (Defining_Name_Image (First_Name (Element)))); end if; end; end if; end Rule_Check_Pre_Op; ------------------------------ -- Unnamed_Blocks_And_Loops -- ------------------------------ ------------------------------------------ -- Init_Rule (Unnamed_Blocks_And_Loops) -- ------------------------------------------ procedure Init_Rule (Rule : in out Unnamed_Blocks_And_Loops_Rule_Type) is begin Init_Rule (Rule_Template (Rule)); Rule.Name := new String'("Unnamed_Blocks_And_Loops"); Rule.Synonym := new String'("Non_Named_Blocks_And_Loops"); Rule.Rule_Status := Fully_Implemented; Rule.Help_Info := new String'("compound statements naming"); Rule.Diagnosis := new String'("#1#non-named block statement" & "#2#non-named nested loop statement" & "#3#non-named nesting loop statement"); end Init_Rule; -------------------------------------------------- -- Rule_Check_Pre_Op (Unnamed_Blocks_And_Loops) -- -------------------------------------------------- procedure Rule_Check_Pre_Op (Rule : in out Unnamed_Blocks_And_Loops_Rule_Type; Element : Asis.Element; Control : in out Traverse_Control; State : in out Rule_Traversal_State) is pragma Unreferenced (Rule, Control); Enclosing_El : Asis.Element; Step_Up : Elmt_Idx := 0; begin case Statement_Kind (Element) is when A_Block_Statement => if Is_Nil (Statement_Identifier (Element)) then State.Detected := True; State.Diagnosis := 1; end if; when A_Loop_Statement | A_While_Loop_Statement | A_For_Loop_Statement => if Is_Nil (Statement_Identifier (Element)) then -- First, check if the loop is nested. In case if a loop -- statement is enclosed in another loop and itself contains a -- loop statement, we generate the second diagnostic variant Enclosing_El := Get_Enclosing_Element (Step_Up); while Element_Kind (Enclosing_El) in A_Statement .. A_Path loop if Statement_Kind (Enclosing_El) in A_Loop_Statement .. A_For_Loop_Statement then State.Detected := True; State.Diagnosis := 2; exit; end if; Step_Up := Step_Up + 1; Enclosing_El := Get_Enclosing_Element (Step_Up); end loop; if not State.Detected then -- Non nested loop, but it may contain other loops State.Detected := Contains_Loop (Element); if State.Detected then State.Diagnosis := 3; end if; end if; end if; when others => null; end case; end Rule_Check_Pre_Op; end Gnatcheck.Rules.Custom_1;