------------------------------------------------------------------------------
--                                                                          --
--                          GNATCHECK COMPONENTS                            --
--                                                                          --
--             G N A T C H E C K . R U L E S . C U S T O M _ 2              --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--                     Copyright (C) 2008-2009, AdaCore                     --
--                                                                          --
-- GNATCHECK  is  free  software;  you can redistribute it and/or modify it --
-- under terms of the  GNU  General Public License as published by the Free --
-- Software Foundation;  either version 2, or ( at your option)  any  later --
-- version.  GNATCHECK  is  distributed in the hope that it will be useful, --
-- but  WITHOUT  ANY  WARRANTY;   without  even  the  implied  warranty  of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General Public License distributed with GNAT; see file  COPYING. If --
-- not,  write to the  Free Software Foundation,  51 Franklin Street, Fifth --
-- Floor, Boston, MA 02110-1301, USA.                                       --
--                                                                          --
-- GNATCHECK is maintained by AdaCore (http://www.adacore.com).             --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines the a set of gnatcheck rules for gnatcheck developed
--  to satisfy some specific requests from gnatcheck users. There is not any
--  specific idea that used to group all these rules together or to make
--  a separate package for user-driven rules when we already have
--  Gnatcheck.Rules.Custom_1, the only reason is to keep the packages for
--  the rules that comes out from user requests under some reasonable size
--  limit.
--
--  The rules in this packages are ordered alphabetically

package Gnatcheck.Rules.Custom_2 is

   ---------------------------------
   -- Complex_Inlined_Subprograms --
   ---------------------------------

   --  Flags a subprogram body if a pragma Inline is applied to this subprogram
   --  and at least one of the following conditions is met:
   --
   --  - the body contains at least one complex declaration such as a
   --    subprogram body, package, task, protected object declaration, or a
   --    generic instantiation (except instantiations of
   --    Ada.Unchecked_Conversion);
   --
   --  - the body contains at least one complex statement such as a loop, a
   --    case or a if statement, or a short circuit control form;
   --
   --  - the body contains more than N statements where N is the unique rule
   --    parameter
   --
   --  The rule has the following parameters:
   --
   --  * for +R option:
   --
   --      N - N is an integer literal, specifies the maximal allowed total
   --          number of local declarations and statements in subprogram body.

   type Complex_Inlined_Subprograms_Rule_Type is new
     One_Integer_Parameter_Rule_Template with null record;

   procedure Rule_Check_Pre_Op
     (Rule    : in out Complex_Inlined_Subprograms_Rule_Type;
      Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  If Element represents a subprogram body, checks the conditions stated
   --  above

   procedure Init_Rule (Rule : in out Complex_Inlined_Subprograms_Rule_Type);

   Complex_Inlined_Subprograms_Rule :
     aliased Complex_Inlined_Subprograms_Rule_Type;

   ----------------------------------
   -- Deep_Inheritance_Hierarchies --
   ----------------------------------

   --  Flags a tagged (derived) type declaration or an interface type
   --  declaration if its depth (in its inheritance hierarchy) exceeds the
   --  value specified by the N rule parameter.
   --
   --  The depth of a tagged type or interface type is defined as 0 for a type
   --  with no parents and otherwise as 1 + max of the depths of the immediate
   --  parents.
   --
   --  The rule has the following parameters:
   --
   --  * for +R option:
   --
   --      N - N is integer not less then -1 specifying the maximal allowed
   --          depth of the inheritance tree. When N = -1, the rule flags all
   --          the declarations of all the tagged and interface types, not
   --          including private extensions.

   type Deep_Inheritance_Hierarchies_Rule_Type is new
     One_Integer_Parameter_Rule_Template with null record;

   procedure Rule_Check_Pre_Op
     (Rule    : in out Deep_Inheritance_Hierarchies_Rule_Type;
      Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  If Element represents a tagged derived type declaration, or formal
   --  derived type declaration with private extension computes the length of
   --  the derivation chain and compares it with the specified limit.

   procedure Init_Rule (Rule : in out Deep_Inheritance_Hierarchies_Rule_Type);

   Deep_Inheritance_Hierarchies_Rule :
     aliased Deep_Inheritance_Hierarchies_Rule_Type;

   ----------------------------------
   -- Deeply_Nested_Local_Inlining --
   ----------------------------------

   --  Flags a subprogram body if a pragma Inline is applied to the
   --  corresponding subprogram (or generic subprogram) and the body contains
   --  a call to another inlined subprogram that results in nested inlining
   --  with nesting depth more than N, where N is a rule papameter. This rule
   --  is similar to Deeply_Inlining rule, but it assumes that calls to
   --  subprograms in with'ed units are not inlided, so all the analysis of the
   --  depth of inlining is limited by the unit where the subprogram body is
   --  located and the units it depends semantically upon. Such analysis may be
   --  usefull for the case when neiter '-gnatn' nor '-gnatN' option is used
   --  when building the executable.
   --
   --  The rule has the following parameters:
   --
   --  * for +R option:
   --
   --      N - N is a positive integer specifying the maximal allowed depth of
   --          nested inlining

   type Deeply_Nested_Local_Inlining_Rule_Type is new
     One_Integer_Parameter_Rule_Template with null record;

   procedure Rule_Check_Pre_Op
     (Rule    : in out Deeply_Nested_Local_Inlining_Rule_Type;
      Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  If Element is a body of inlined (generic) subprogram, checks if the
   --  body contains calls to another inlined subprogram from the same unit
   --  that results in nested inlining deeper then N levels. Assumes that
   --  recursive subprograms cannot be inlined.

   procedure Init_Rule (Rule : in out Deeply_Nested_Local_Inlining_Rule_Type);

   Deeply_Nested_Local_Inlining_Rule :
     aliased Deeply_Nested_Local_Inlining_Rule_Type;

   ----------------------------
   -- Deeply_Nested_Generics --
   ----------------------------

   --  Flags generic declarations nested in another generic declarations if
   --  the if the level of generics-in-generics nesting is higher then the
   --  specified limit. The level of generics-in-generics nesting is the
   --  number of generic declaratons that enclose the given (generic)
   --  declaration. Formal packages are not flagged by this rule.
   --
   --  The rule has the following parameters:
   --
   --  * for +R option:
   --
   --      N - N is an positive integer literal, specifies the maximal allowed
   --          level of generics-in-generics  nesting. This parameter is
   --          mandatory for +R option.

   type Deeply_Nested_Generics_Rule_Type is new
     One_Integer_Parameter_Rule_Template with null record;

   procedure Rule_Check_Pre_Op
     (Rule    : in out Deeply_Nested_Generics_Rule_Type;
      Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  If Element represents a generic declaration, checks in how many other
   --  generic declarations it is nested.

   procedure Init_Rule (Rule : in out Deeply_Nested_Generics_Rule_Type);

   Deeply_Nested_Generics_Rule : aliased Deeply_Nested_Generics_Rule_Type;

   --------------------------------
   -- Direct_Calls_To_Primitives --
   --------------------------------

   --  Flags any non-dispatching calls to a dispatching primitive operation
   --  is flagged except in one circumstance: when a primitive of a tagged
   --  type calls directly the same primitive of the immediate ancestor.
   --
   --  This rule does not have any parameter.

   type Direct_Calls_To_Primitives_Rule_Type is new Rule_Template
     with null record;

   procedure Rule_Check_Pre_Op
     (Rule    : in out Direct_Calls_To_Primitives_Rule_Type;
      Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  If Element is a non-dispatching procesure or function call, checks if
   --  the called subprogram is a primitive operation of a type, and if it is,
   --  checks if the call is located in the body of child's primitive

   procedure Init_Rule (Rule : in out Direct_Calls_To_Primitives_Rule_Type);

   Direct_Calls_To_Primitives_Rule :
     aliased Direct_Calls_To_Primitives_Rule_Type;

   ----------------------------------
   -- Exits_From_Conditional_Loops --
   ----------------------------------

   --  Flags any exit statement if it transfers the control out of a FOR loop
   --  or a WHILE loop. This includes cases when the exit statement applies to
   --  a FOR or WHILE loop, and cases when in is enclosed in some FOR or WHILE
   --  loop, but transfers the control from some outer (inconditional) loop.
   --
   --  The rule does not have any parameter.

   type Exits_From_Conditional_Loops_Rule_Type is
     new Rule_Template with null record;

   procedure Rule_Check_Pre_Op
     (Rule    : in out Exits_From_Conditional_Loops_Rule_Type;
      Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  If Element represents an exit statement, checks what is the kind of the
   --  corresponding loop being exited.

   procedure Init_Rule (Rule : in out Exits_From_Conditional_Loops_Rule_Type);

   Exits_From_Conditional_Loops_Rule :
     aliased Exits_From_Conditional_Loops_Rule_Type;

   -------------------------------------
   -- Misnamed_Controlling_Parameters --
   -------------------------------------

   --  Flags a declaration of a dispatching operation, if the first parameter
   --  is not a controlling one and its name is not @code{This} (the check for
   --  parameter name is not case-sensitive). Declarations of dispatching
   --  functions with controlling result and no controlling parameter are never
   --  flagged.
   --
   --  A subprogram body declaration, subprogram renaming declaration of
   --  subprogram body stub is flagged only if it is not a completion of a
   --  pripr subprogram declaration.
   --
   --  This rule has no parameters.

   type Misnamed_Controlling_Parameters_Rule_Type is
     new Rule_Template with null record;

   procedure Rule_Check_Pre_Op
     (Rule    : in out Misnamed_Controlling_Parameters_Rule_Type;
      Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  If Element represents primitive operation of a tagged type, checks if
   --  it follows the stype requirements listed above.

   procedure Init_Rule
     (Rule : in out Misnamed_Controlling_Parameters_Rule_Type);

   Misnamed_Controlling_Parameters_Rule :
     aliased Misnamed_Controlling_Parameters_Rule_Type;

   -------------------------------------
   -- Separate_Numeric_Error_Handlers --
   -------------------------------------

   --  Flags any exception handler that contains the choice for
   --  Constrain_Error, but does not contains the choice for Numeric_Error, or
   --  that contains the choice for Numeric_Error, but does not contain the
   --  choice for Constraint_Error. (Constraint_Error and Numeric_Error mean
   --  predefined exceptions for this rule).
   --
   --  The rule does not mean very much sense for Ada 95 and Ada 2005 programs,
   --  where Numeric_Error is just a renaming of Constraint_Error, but it
   --  allows to verify if for Ada 83 programs (where Numeric_Error is
   --  different from Constraint_Error) the exception handling is the same in
   --  Ada 83 and Ada 95 (2005) modes.
   --
   --  The rule does not have any parameter.

   type Separate_Numeric_Error_Handlers_Rule_Type is
     new Rule_Template with null record;

   procedure Rule_Check_Pre_Op
     (Rule    : in out Separate_Numeric_Error_Handlers_Rule_Type;
      Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  If Element represents an exception handler, checks if its choices either
   --  contains both Constraint_Error and Numeric_Error or nither of these
   --  predefined exceptions. In case if an exception name representing a
   --  choice in the exception handler is defined by a renaming declaration,
   --  the procedure traverses the renaming chain.

   procedure Init_Rule
     (Rule : in out Separate_Numeric_Error_Handlers_Rule_Type);

   Separate_Numeric_Error_Handlers_Rule :
     aliased Separate_Numeric_Error_Handlers_Rule_Type;

   ----------------------
   -- Too_Many_Parents --
   ----------------------

   --  Flags any type declaration, single task declaration or single protected
   --  declaration that has more than N parents, N is a parameter of the rule.
   --  A parent here is either a (sub)type denoted by the subtype mark from the
   --  parent_subtype_indication (in case of a derived type declaration), or
   --  any of the progenitors from the interface list, if any.
   --
   --  The rule has the following parameters:
   --
   --  * for +R option:
   --
   --      N - N is a positive integer, specifies the maximal allowed number of
   --          parents.
   --

   type Too_Many_Parents_Rule_Type is new One_Integer_Parameter_Rule_Template
     with null record;

   procedure Rule_Check_Pre_Op
     (Rule    : in out Too_Many_Parents_Rule_Type;
      Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  If Element represents a declaration that can have more than one parent,
   --  counts the number of parents and compares with the maximal allowed
   --  number of parents specified for the rule.
   --
   --  The following ASIS A_Declaration elements may have more than ore parent:
   --     An_Ordinary_Type_Declaration (provided that the corresponding
   --       A_Type_Definition Element is of
   --       A_Derived_Record_Extension_Definition or
   --       An_Interface_Type_Definition kind)
   --     A_Formal_Type_Declaration (provided that the corresponding
   --       A_Formal_Type_Definition Element is
   --       of A_Formal_Derived_Type_Definition kind)
   --     A_Private_Extension_Declaration
   --     A_Task_Type_Declaration
   --     A_Protected_Type_Declaration
   --     A_Single_Task_Declaration
   --     A_Single_Protected_Declaration

   procedure Init_Rule (Rule : in out Too_Many_Parents_Rule_Type);

   Too_Many_Parents_Rule : aliased Too_Many_Parents_Rule_Type;

   -------------------------
   -- Unconditional_Exits --
   -------------------------

   --  Flags all the unconditional exit statements.
   --
   --  The rule does not have any parameter.
   --
   type Unconditional_Exits_Rule_Type is new Rule_Template with null record;

   procedure Rule_Check_Pre_Op
     (Rule    : in out Unconditional_Exits_Rule_Type;
      Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  If Element represents an exit statement checks if it contains a
   --  condition.

   procedure Init_Rule (Rule : in out Unconditional_Exits_Rule_Type);

   Unconditional_Exits_Rule : aliased Unconditional_Exits_Rule_Type;

   ------------------------
   -- Visible_Components --
   ------------------------

   --  Flags all the type declarations located in the visible part of a library
   --  package or a library generic package that can declare a visible
   --  component. A type is considered as declaring a visible component if it
   --  contains a record definition by its own or as a part of a record
   --  extension. Type declaration is flagged even if it contains a record
   --  definition that defines no components.
   --
   --  Declarations located in private parts of local (generic) packages are
   --  not flagged. Declarations in private packages are not flagged.
   --
   --  The rule does not have any parameter.

   type Visible_Components_Rule_Type is
     new Rule_Template with null record;

   procedure Rule_Check_Pre_Op
     (Rule    : in out Visible_Components_Rule_Type;
      Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  If Element represents a type declaration that defines a record
   --  component checks if it is located in the visible part of a library
   --  package or a generic library package. If the type declaration is located
   --  in the private part of a local package, it is not flagged.

   procedure Init_Rule (Rule : in out Visible_Components_Rule_Type);

   Visible_Components_Rule : aliased Visible_Components_Rule_Type;

end Gnatcheck.Rules.Custom_2;
