------------------------------------------------------------------------------
--                                                                          --
--                      GNAT METRICS TOOLS COMPONENTS                       --
--                                                                          --
--               M E T R I C S . A S I S _ U T I L I T I E S                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2002-2006, AdaCore                     --
--                                                                          --
-- GNAT Metrics Toolset  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.  GNAT Metrics Toolset is  distributed in the hope that it --
-- will be useful, but  WITHOUT ANY WARRANTY; without even the implied war- --
-- ranty 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.                         --
--                                                                          --
-- GNAT Metrics Toolset is maintained by AdaCore - (http://www.adacore.com) --                                                --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling;    use Ada.Characters.Handling;
with Types;                      use Types;
with Atree;                      use Atree;
with Einfo;                      use Einfo;

with Asis.Compilation_Units;     use Asis.Compilation_Units;
with Asis.Elements;              use Asis.Elements;
with Asis.Declarations;          use Asis.Declarations;
with Asis.Definitions;           use Asis.Definitions;
with Asis.Statements;            use Asis.Statements;
with Asis.Expressions;           use Asis.Expressions;
with Asis.Extensions;            use Asis.Extensions;
with Asis.Iterator;              use Asis.Iterator;
with Asis.Text;                  use Asis.Text;

with Asis.Set_Get;               use Asis.Set_Get;

package body METRICS.ASIS_Utilities is

   -----------------------
   -- Local subprograms --
   -----------------------

   function Is_Static_Subtype (E : Element) return Boolean;
   --  Checks if the argument is a static subtype indication or a static
   --  A_Discrete_Subtype_Definition. This function is supposed to be applied
   --  to discrete subtype indications (and definitions) of the form
   --  subtype_mark [constraint].

   CU_Profile_Buffer : String (1 .. 1024);
   CU_Buf_Len        : Natural;
   --  Buffer to form the beginning of CU_Profille result

   procedure Add (S : String);
   --  Appends S to CU_Profile_Buffer, moving Cu_Buf_Len accordingly

   function Contains
     (Outer : Element;
      Inner : Element)
      return  Boolean;
   --  Checks if Outer contains Inner. At the moment this function is
   --  implemented for explicit elements only, or, more precisely, for the
   --  situation when for both arguments Is_Text_Available. If at least one of
   --  the parameters does not have a text properties available, False is
   --  returned.
   --
   --  Note, that the current implementation assumes that both arguments are
   --  from the same Compilation_Unit!

   ---------
   -- Add --
   ---------

   procedure Add (S : String) is
   begin
      --  The buffer is never supposed to be filled completely

      CU_Profile_Buffer (CU_Buf_Len + 1 .. CU_Buf_Len + S'Length) := S;
      CU_Buf_Len := CU_Buf_Len + S'Length;
   end Add;

   ----------------------------
   -- Adds_New_Nesting_Level --
   ----------------------------

   function Adds_New_Nesting_Level
     (El_Kind : Flat_Element_Kinds)
      return    Boolean
   is
      Result : Boolean := False;
   begin

      case El_Kind is
         when A_Procedure_Body_Declaration       |
              A_Function_Body_Declaration        |
              A_Package_Declaration              |
              A_Package_Body_Declaration         |
              A_Task_Body_Declaration            |
              A_Protected_Body_Declaration       |
              An_Entry_Body_Declaration          |
              A_Generic_Package_Declaration      |
              An_If_Statement                    |
              A_Case_Statement                   |
              A_Loop_Statement                   |
              A_While_Loop_Statement             |
              A_For_Loop_Statement               |
              A_Block_Statement                  |
              An_Accept_Statement                |
              A_Selective_Accept_Statement       |
              A_Timed_Entry_Call_Statement       |
              A_Conditional_Entry_Call_Statement |
              An_Asynchronous_Select_Statement   =>
            Result := True;
         when others =>
            null;
      end case;

      return Result;
   end Adds_New_Nesting_Level;

   --------------
   -- Contains --
   --------------

   function Contains
     (Outer : Element;
      Inner : Element)
      return  Boolean
   is
      Outer_Span : Span;
      Inner_Span : Span;
      Result     : Boolean := False;
   begin

      if Is_Text_Available (Outer) and then
         Is_Text_Available (Inner)
      then
         Outer_Span := Element_Span (Outer);
         Inner_Span := Element_Span (Inner);

         if (Outer_Span.First_Line < Inner_Span.First_Line
            or else
             (Outer_Span.First_Line = Inner_Span.First_Line and then
              Outer_Span.First_Column <= Inner_Span.First_Column))

         and then

            (Outer_Span.Last_Line  > Inner_Span.Last_Line
            or else
             (Outer_Span.Last_Line = Inner_Span.Last_Line and then
              Outer_Span.Last_Column >= Inner_Span.Last_Column))
         then
            Result := True;
         end if;

      end if;

      return Result;
   end Contains;

   -----------------------------
   -- Control_Form_Complexity --
   -----------------------------

   function Control_Form_Complexity (Expr : Element) return Metric_Count is
      Result   : Metric_Count       := 0;
      Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Expr);
      Tmp      : Asis.Element;
   begin

      if Flat_Element_Kind (Enclosing_Element (Expr)) /= Arg_Kind then
         --  that is, in case of A and then B and then C we compute the
         --  complexity only once and for the "whole" short-circuit.

         Result := 1;

         Tmp := Short_Circuit_Operation_Left_Expression (Expr);

         while Flat_Element_Kind (Tmp) = Arg_Kind loop
            Tmp := Short_Circuit_Operation_Left_Expression (Tmp);
            Result := Result + 1;
         end loop;

      end if;

      return Result;
   end Control_Form_Complexity;

   ----------------
   -- CU_Profile --
   ----------------

   function CU_Profile (CU : Compilation_Unit) return String is
      Arg_Kind        : constant Unit_Kinds   := Unit_Kind (CU);
      Arg_Class       : constant Unit_Classes := Unit_Class (CU);
      Is_Generic_Body : Boolean               := False;
   begin

      CU_Buf_Len := 0;

      if Arg_Class in A_Private_Declaration .. A_Private_Body then
         Add ("private ");
      end if;

      if Arg_Kind in A_Library_Unit_Body then
         Is_Generic_Body :=
           Unit_Kind (Corresponding_Declaration (CU)) in
           A_Generic_Unit_Declaration;
      end if;

      case Arg_Kind is
         when A_Procedure =>
            Add ("procedure ");
         when A_Function =>
            Add ("function ");
         when A_Package =>
            Add ("package ");
         when A_Generic_Procedure =>
            Add ("generic procedure ");
         when A_Generic_Function =>
            Add ("generic function ");
         when A_Generic_Package =>
            Add ("generic package ");
         when A_Procedure_Instance =>
            Add ("procedure instance ");
         when A_Function_Instance =>
            Add ("function instance ");
         when A_Package_Instance =>
            Add ("package instance ");
         when A_Procedure_Renaming =>
            Add ("procedure renaming ");
         when A_Function_Renaming =>
            Add ("function renaming ");
         when A_Package_Renaming =>
            Add ("package renaming ");
         when A_Generic_Procedure_Renaming =>
            Add ("generic procedure renaming ");
         when A_Generic_Function_Renaming =>
            Add ("generic function renaming ");
         when A_Generic_Package_Renaming =>
            Add ("generic package renaming ");

         when A_Procedure_Body =>

            if Is_Generic_Body then
               Add ("generic ");
            end if;

            Add ("procedure body ");

         when A_Function_Body =>

            if Is_Generic_Body then
               Add ("generic ");
            end if;

            Add ("function body ");

         when A_Package_Body =>

            if Is_Generic_Body then
               Add ("generic ");
            end if;

            Add ("package body ");

         when A_Procedure_Body_Subunit =>
            Add ("procedure body subunit ");
         when A_Function_Body_Subunit =>
            Add ("function body subunit ");
         when A_Package_Body_Subunit =>
            Add ("package body subunit ");
         when A_Task_Body_Subunit =>
            Add ("tack body subunit ");
         when A_Protected_Body_Subunit =>
            Add ("protected body subunit ");

         when others =>
            null;
      end case;

      return CU_Profile_Buffer (1 .. CU_Buf_Len) &
             To_String (Unit_Full_Name (CU));

   end CU_Profile;

   ------------------------
   -- Is_Executable_Body --
   ------------------------

   function Is_Executable_Body (El : Element) return Boolean is
      El_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (El);
      Result  : Boolean                     := False;
   begin

      case El_Kind is

         when A_Procedure_Body_Declaration |
              A_Function_Body_Declaration  |
              A_Task_Body_Declaration      |
              An_Entry_Body_Declaration    =>
            Result := True;
         when A_Package_Body_Declaration =>
            Result := Body_Statements (El)'Length > 0;
         when others =>
            null;
      end case;

      return Result;
   end Is_Executable_Body;

   ---------------------------------
   -- Is_Non_Structural_Statement --
   ---------------------------------

   function Is_Non_Structural_Statement
     (Stmt         : Element;
      Exit_Is_Goto : Boolean := True)
      return         Boolean
   is
      Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Stmt);

      Result  : Boolean          := False;
      Control : Traverse_Control := Continue;

      Target_Stmt : Element;

      procedure Pre_Operation
        (Element :        Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Boolean);
      --  This procedure does most of the job. It checks if the element being
      --  visited does transfer the control outside Stmt. If this is really so
      --  it sets Result to True and terminates the traversal

      procedure Post_Operation
        (Element :        Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Boolean);

      procedure Check_Statement is new
        Traverse_Element (Boolean, Pre_Operation, Post_Operation);

      procedure Pre_Operation
        (Element :        Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Boolean)
      is
         Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Element);
      begin

         case Arg_Kind is
            when Flat_Path_Kinds                    |
                 An_If_Statement                    |
                 A_Case_Statement                   |
                 A_Loop_Statement                   |
                 A_While_Loop_Statement             |
                 A_For_Loop_Statement               |
                 A_Block_Statement                  |
                 A_Selective_Accept_Statement       |
                 A_Timed_Entry_Call_Statement       |
                 A_Conditional_Entry_Call_Statement |
                 An_Asynchronous_Select_Statement   =>

               --  We may control transfer inside such a construct. So just
               --  continue...
               null;

            when A_Return_Statement                |
                 A_Raise_Statement                 |
                 A_Terminate_Alternative_Statement =>

               State   := True;
               Control := Terminate_Immediately;

            when An_Exit_Statement =>

               if Exit_Is_Goto then
                  Target_Stmt := Corresponding_Loop_Exited (Element);

                  if not Contains (Outer => Stmt, Inner => Target_Stmt) or else
                     Is_Equal (Stmt, Target_Stmt)
                  then
                     State   := True;
                     Control := Terminate_Immediately;
                  end if;

               end if;

            when A_Goto_Statement =>

               Target_Stmt := Corresponding_Destination_Statement (Element);

               if not Contains (Outer => Stmt, Inner => Target_Stmt) or else
                  Is_Equal (Stmt, Target_Stmt)
               then
                  State   := True;
                  Control := Terminate_Immediately;
               end if;

            when others =>
               --  Nothing interesting inside...
               Control := Abandon_Children;
         end case;

      end Pre_Operation;

      procedure Post_Operation
        (Element :        Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Boolean)
      is
      begin
         pragma Unreferenced (Element);
         pragma Unreferenced (Control);
         pragma Unreferenced (State);
         null;
      end Post_Operation;

   begin

      if Arg_Kind = An_If_Statement                    or else
         Arg_Kind = A_Case_Statement                   or else
         Arg_Kind = A_Loop_Statement                   or else
         Arg_Kind = A_While_Loop_Statement             or else
         Arg_Kind = A_For_Loop_Statement               or else
         Arg_Kind = A_Selective_Accept_Statement       or else
         Arg_Kind = A_Timed_Entry_Call_Statement       or else
         Arg_Kind = A_Conditional_Entry_Call_Statement or else
         Arg_Kind = An_Asynchronous_Select_Statement
      then
         Check_Statement (Stmt, Control, Result);
      end if;

      return Result;
   end Is_Non_Structural_Statement;

   ---------------------
   -- Is_Program_Unit --
   ---------------------

   function Is_Program_Unit (El : Element) return Boolean is
      El_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (El);
      Result  : Boolean                     := False;
   begin

      Result := False
        or else El_Kind = A_Task_Type_Declaration
        or else El_Kind = A_Protected_Type_Declaration
        or else El_Kind = A_Single_Task_Declaration
        or else El_Kind = A_Single_Protected_Declaration
        or else El_Kind = A_Package_Declaration
        or else El_Kind = A_Generic_Package_Declaration
        or else El_Kind = A_Package_Body_Declaration
        or else El_Kind = A_Procedure_Body_Declaration
        or else El_Kind = A_Function_Body_Declaration
        or else El_Kind = A_Task_Body_Declaration
        or else El_Kind = A_Protected_Body_Declaration
        or else El_Kind = An_Entry_Body_Declaration;

      if not Result then

         Result := False
           or else El_Kind = A_Procedure_Declaration
           or else El_Kind = A_Function_Declaration
           or else El_Kind = A_Generic_Procedure_Declaration
           or else El_Kind = A_Generic_Function_Declaration
           or else El_Kind = A_Package_Instantiation
           or else El_Kind = A_Procedure_Instantiation
           or else El_Kind = A_Function_Instantiation
           or else El_Kind = A_Package_Renaming_Declaration
           or else El_Kind = A_Procedure_Renaming_Declaration
           or else El_Kind = A_Function_Renaming_Declaration
           or else El_Kind = A_Generic_Package_Renaming_Declaration
           or else El_Kind = A_Generic_Procedure_Renaming_Declaration
           or else El_Kind = A_Generic_Function_Renaming_Declaration;

         Result :=
           Result and then
           Is_Equal (El, Unit_Declaration (Enclosing_Compilation_Unit (El)));
      end if;

      return Result;

   end Is_Program_Unit;

   ------------------------
   -- Is_RM_Program_Unit --
   ------------------------

   function Is_RM_Program_Unit (El : Element) return Boolean is
      Result  : Boolean                     := False;
      El_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (El);
   begin

      Result := False
        or else El_Kind = A_Task_Type_Declaration
        or else El_Kind = A_Protected_Type_Declaration
        or else El_Kind = A_Single_Task_Declaration
        or else El_Kind = A_Single_Protected_Declaration
        or else El_Kind = A_Procedure_Declaration
        or else El_Kind = A_Function_Declaration
        or else El_Kind = A_Procedure_Body_Declaration
        or else El_Kind = A_Function_Body_Declaration
        or else El_Kind = A_Package_Declaration
        or else El_Kind = A_Package_Body_Declaration
        or else El_Kind = A_Task_Body_Declaration
        or else El_Kind = A_Protected_Body_Declaration
        or else El_Kind = An_Entry_Body_Declaration
        or else El_Kind = A_Procedure_Body_Stub
        or else El_Kind = A_Function_Body_Stub
        or else El_Kind = A_Package_Body_Stub
        or else El_Kind = A_Task_Body_Stub
        or else El_Kind = A_Protected_Body_Stub
        or else El_Kind = A_Generic_Procedure_Declaration
        or else El_Kind = A_Generic_Function_Declaration
        or else El_Kind = A_Generic_Package_Declaration;

      if El_Kind = An_Entry_Declaration then
         Result :=
           Definition_Kind (Enclosing_Element (El)) = A_Protected_Definition;
      end if;

      return Result;

   end Is_RM_Program_Unit;

   --------------------
   -- Is_Static_Loop --
   --------------------

   function Is_Static_Loop (Loop_Stmt : Element) return Boolean
   is
      Param_Definition : Element;

      Result : Boolean := False;
   begin

      if Flat_Element_Kind (Loop_Stmt) = A_For_Loop_Statement then

         Param_Definition :=
           Specification_Subtype_Definition
             (For_Loop_Parameter_Specification (Loop_Stmt));

         case Flat_Element_Kind (Param_Definition) is

            when A_Discrete_Subtype_Indication_As_Subtype_Definition =>

               Result := Is_Static_Subtype (Param_Definition);
               --  Is_Static_Subtype (Subtype_Constraint (Param_Definition));

            when A_Discrete_Range_Attribute_Reference_As_Subtype_Definition =>
               Result := Is_Static (Param_Definition);

            when A_Discrete_Simple_Expression_Range_As_Subtype_Definition =>

               Result := Is_Static (Lower_Bound (Param_Definition)) and then
                         Is_Static (Upper_Bound (Param_Definition));

            when others =>
               null;
         end case;

      end if;

      return Result;
   end Is_Static_Loop;

   -----------------------
   -- Is_Static_Subtype --
   -----------------------

   function Is_Static_Subtype (E : Element) return Boolean is
      Result   : Boolean                     := False;
      Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (E);

      Def_Name    : Element;
      Type_Entity : Entity_Id;
      Tmp         : Element;
   begin
      --  Note, that this NOT an ASIS secondary query, some routines from
      --  Einfo are used.

      --  First, return False for any non-expected or definitely non-static
      --  result

      if not (Arg_Kind = A_Subtype_Indication          or else
              Arg_Kind = A_Discrete_Subtype_Indication or else
              Arg_Kind = A_Discrete_Subtype_Indication_As_Subtype_Definition)
      then
         return False;
      end if;

      Tmp := Asis.Definitions.Subtype_Mark (E);

      if Flat_Element_Kind (Tmp) = A_Selected_Component then
         Tmp := Selector (Tmp);
      end if;

      Def_Name    := Corresponding_Name_Definition (Tmp);
      Type_Entity := Node (Def_Name);

      if Is_Non_Static_Subtype (Type_Entity) or else
         Ekind (Type_Entity) not in Discrete_Kind
      then
         return False;
      end if;

      --  If we are here, we are sure that we are processing some discrete
      --  subtype indication

      Tmp := Subtype_Constraint (E);

      if not Is_Nil (Tmp) then

         if Flat_Element_Kind (Tmp) = A_Range_Attribute_Reference then
            Result := Is_Static (Tmp);
         else
            Result := Is_Static (Lower_Bound (Tmp)) and then
                      Is_Static (Upper_Bound (Tmp));
         end if;

         if not Result then
            --  The constraint is not static. No chance to be a static
            --  subtype...
            return False;
         end if;

      end if;

      --  If we are here, the constraint is either absent or static. So,
      --  checking the subtype mark

      Tmp := Type_Declaration_View (Enclosing_Element (Def_Name));

      if Flat_Element_Kind (Tmp) = A_Subtype_Indication then
         Result := Is_Static_Subtype (Tmp);
      else
         --  that is, here we have a type definition

         case Flat_Element_Kind (Tmp) is

            when A_Derived_Type_Definition =>
               Result := Is_Static_Subtype (Parent_Subtype_Indication (Tmp));

            when An_Enumeration_Type_Definition   |
                 A_Signed_Integer_Type_Definition |
                 A_Modular_Type_Definition =>
               Result := True;

            when others =>
               Result := False;
         end case;

      end if;

      return Result;
   end Is_Static_Subtype;

   -------------------------------
   -- May_Contain_Program_Units --
   -------------------------------

   function May_Contain_Program_Units
     (El_Kind : Flat_Element_Kinds)
      return    Boolean
   is
   begin

      return False
        or else El_Kind = A_Task_Type_Declaration
        or else El_Kind = A_Protected_Type_Declaration
        or else El_Kind = A_Single_Task_Declaration
        or else El_Kind = A_Single_Protected_Declaration
        or else El_Kind = A_Package_Declaration
        or else El_Kind = A_Generic_Package_Declaration
        or else El_Kind = A_Package_Body_Declaration
        or else El_Kind = A_Procedure_Body_Declaration
        or else El_Kind = A_Function_Body_Declaration
        or else El_Kind = A_Task_Body_Declaration
        or else El_Kind = A_Protected_Body_Declaration
        or else El_Kind = An_Entry_Body_Declaration;

   end May_Contain_Program_Units;

   ---------------------------
   --  Statement_Complexity --
   ---------------------------

   function Statement_Complexity (Stmt : Element) return Metric_Count is
      Result     : Metric_Count                := 0;
      Arg_Kind   : constant Flat_Element_Kinds := Flat_Element_Kind (Stmt);
   begin

      case Arg_Kind is

         when An_If_Statement              |
              A_Case_Statement             |
              A_Selective_Accept_Statement =>

            declare
               Paths : constant Element_List := Statement_Paths (Stmt);
            begin

               if Arg_Kind = An_If_Statement then
                  Result := Paths'Length;

                  if Flat_Element_Kind (Paths (Paths'Last)) = An_Else_Path then
                     Result := Result - 1;
                  end if;

               else
                  Result := Paths'Length - 1;
               end if;

            end;

         when A_While_Loop_Statement             |
              A_Timed_Entry_Call_Statement       |
              A_Conditional_Entry_Call_Statement |
              An_Asynchronous_Select_Statement   |
              A_For_Loop_Statement =>

            Result := 1;

         when An_Exit_Statement =>

            if not Is_Nil (Exit_Condition (Stmt)) then
               Result := 1;
            end if;

         when others =>
            null;
      end case;

      return Result;
   end Statement_Complexity;

end METRICS.ASIS_Utilities;
