------------------------------------------------------------------------------
--                                                                          --
--                          GNATCHECK COMPONENTS                            --
--                                                                          --
--              G N A T S Y N C . A S I S _ U T I L I T I E S               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                    Copyright (C) 2007-2010, AdaCore                      --
--                                                                          --
-- GNATSYNC  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.                                       --
--                                                                          --
-- GNATSYNC is maintained by AdaCore (http://www.adacore.com).              --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling;    use Ada.Characters.Handling;

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

with Asis.Set_Get;               use Asis.Set_Get;

with ASIS_UL.Output;             use ASIS_UL.Output;
with ASIS_UL.Strings;            use ASIS_UL.Strings;

with Atree;                      use Atree;
with Sinfo;                      use Sinfo;
with Einfo; use Einfo;
with Types; use Types;

package body Gnatsync.ASIS_Utilities is

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

   procedure Look_For_Enclosed_Tasks_Pre_Op
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Boolean);
   --  Checks if Argument is a task or task type declaration. Skips elements
   --  that cannot contain task (type) declarations. As soon as a task (type)
   --  declaration is found, sets State to True and terminates traversing

   procedure Look_For_Enclosed_Tasks_Post_Op
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Boolean);
   --  Does nothing

   procedure Look_For_Enclosed_Tasks is new Traverse_Element
     (Boolean,
      Look_For_Enclosed_Tasks_Pre_Op,
      Look_For_Enclosed_Tasks_Post_Op);

   ---------------------------------------
   -- Can_Be_Accessed_By_Enclosed_Tasks --
   ---------------------------------------

   function Can_Be_Accessed_By_Enclosed_Tasks
     (El   : Asis.Element)
      return Boolean
   is
      Result     : Boolean := False;
      Encl_Scope : Asis.Element;
      Control    : Traverse_Control := Continue;
   begin

      if Declaration_Kind (El) = A_Variable_Declaration then
         Encl_Scope := Enclosing_Scope (El);
         pragma Assert (not Is_Nil (Encl_Scope));

         Look_For_Enclosed_Tasks (Encl_Scope, Control, Result);
      end if;

      return Result;
   end Can_Be_Accessed_By_Enclosed_Tasks;

   ---------------------------
   -- Corresponding_Element --
   ---------------------------

   function Corresponding_Element (El : Asis.Element) return Asis.Element is
      Result  : Asis.Element := El;
      Res_Old : Asis.Element := El;
   begin

      --  What about A_Task_Body_Stub????

      case Declaration_Kind (Result) is
         when A_Task_Body_Declaration =>
            --  Return the argument Element
            null;
         when A_Procedure_Declaration |
              A_Function_Declaration  =>

            if Is_Part_Of_Inherited (Result) then
               Result := Corresponding_Declaration (Result);
               Result := Corresponding_Element (Result);
            end if;

            if Is_Part_Of_Instance (Result) then
               Res_Old := Result;

               Result := Enclosing_Element (Result);

               if Declaration_Kind (Result) not in
                    A_Procedure_Instantiation .. A_Function_Instantiation
               then
                  --  Not an expanded spec, so undo the step up:
                  Result := Res_Old;
               end if;

            end if;

         when A_Procedure_Body_Declaration |
              A_Function_Body_Declaration  |
              A_Procedure_Body_Stub        |
              A_Function_Body_Stub         =>

            Result := Corresponding_Declaration (Result);

            if Is_Nil (Result) then

               if Is_Subunit (El) then
                  Result :=
                    Corresponding_Element (Corresponding_Body_Stub (El));
               else
                  --  No explicit spec
                  Result := El;

               end if;

            end if;

         when A_Procedure_Renaming_Declaration |
              A_Function_Renaming_Declaration =>
            Result := Get_Renamed_Subprogram (El);

         when others =>
            null;
      end case;

      return Result;
   end Corresponding_Element;

   ---------------------
   -- Enclosing_Scope --
   ---------------------

   function Enclosing_Scope (El : Asis.Element) return Asis.Element is
      Result : Asis.Element := El;
   begin

      while not Is_Nil (Result) loop

         if Is_Subunit (Result) then
            Result := Corresponding_Body_Stub (Result);
         else
            Result := Enclosing_Element (Result);
         end if;

         exit when Is_Scope (Result);
      end loop;

      return Result;
   end Enclosing_Scope;

   ------------------------
   -- Get_Called_Element --
   ------------------------

   function Get_Called_Element (El : Asis.Element) return Asis.Element is
   begin

      if Expression_Kind (El) = A_Function_Call then
         return Corresponding_Called_Function (El);
      else
         return Corresponding_Called_Entity (El);
      end if;

   end Get_Called_Element;

   --------------------
   -- Get_Enity_Name --
   --------------------

   function Get_Enity_Name (El : Asis.Element) return String is
      Entity_Def_Name : Asis.Element := El;
   begin

      if Defining_Name_Kind (El) /= A_Defining_Identifier then
         --  Callable entity
         Entity_Def_Name := First_Name (Entity_Def_Name);
      end if;

      return To_String (Defining_Name_Image (Entity_Def_Name));

   end Get_Enity_Name;

   -----------------------
   -- Get_Expanded_Name --
   -----------------------

   function Get_Expanded_Name (El : Asis.Element) return Wide_String_Access
   is
      Arg_Element        : Asis.Element := El;
      Next_Scope         : Asis.Element;
      Result, Tmp_Result : Wide_String_Access;
      First_Idx, Idx     : Natural;
   begin

      --  The current implementation limitation is: we should compute the
      --  correct result only for the declarations from library package
      --  declarations (and for defining expanded names)

      if Element_Kind (Arg_Element) = A_Declaration then
         Arg_Element := First_Name (Arg_Element);
      end if;

      case Defining_Name_Kind (Arg_Element) is
         when A_Defining_Identifier .. A_Defining_Operator_Symbol =>
            Result := new Wide_String'(Defining_Name_Image (Arg_Element));

            Next_Scope := Enclosing_Element (Enclosing_Element (Arg_Element));

            while not (Is_Nil (Next_Scope)
                     or else
                       Declaration_Kind (Next_Scope) = A_Package_Declaration
                     or else
                       Declaration_Kind (Next_Scope) in
                         A_Generic_Instantiation)
            loop
               Next_Scope := Enclosing_Element (Next_Scope);
            end loop;

            if not Is_Nil (Next_Scope) then
               Tmp_Result  :=
                 new Wide_String'
                   (Get_Expanded_Name (Next_Scope).all & '.' & Result.all);
               Free (Result);
               Result := Tmp_Result;
            end if;

         when A_Defining_Expanded_Name =>
            Result := new Wide_String'(Element_Image (El));
            --  And now - remove white spaces, if any
            Tmp_Result := new Wide_String (Result'Range);

            First_Idx := Tmp_Result'First;
            Idx       := First_Idx - 1;

            for J in Result'Range loop

               if not Is_White_Space (To_Character (Result (J))) then
                  Idx := Idx + 1;
                  Tmp_Result (Idx) := Result (J);
               end if;

            end loop;

            Free (Result);
            Result := new Wide_String'(Tmp_Result (First_Idx .. Idx));
            Free (Tmp_Result);
            return Result;

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

      return Result;
   end Get_Expanded_Name;

   ----------------------------
   -- Get_Renamed_Subprogram --
   ----------------------------

   function Get_Renamed_Subprogram (El : Asis.Element) return Asis.Element is
      Result : Asis.Element;
   begin
      Result := Corresponding_Base_Entity (El);

      if Expression_Kind (Result) = A_Selected_Component then
         Result := Selector (Result);
      end if;

      case Expression_Kind (Result) is
         when An_Identifier |
              An_Operator_Symbol =>
            Result := Corresponding_Name_Declaration (Result);

            if Declaration_Kind (Result) in A_Procedure_Renaming_Declaration ..
                 A_Function_Renaming_Declaration
            then
               Result := Get_Renamed_Subprogram (Result);
            end if;

         when An_Attribute_Reference |
              An_Enumeration_Literal =>
            null;
         when others =>
            Result := Nil_Element;
      end case;

      if Is_Nil (Result) then
         Warning (Build_GNAT_Location (El) &
                   ": subprogram renamimg can not be resolved statically");
      end if;

      return Result;
   end Get_Renamed_Subprogram;

   ---------------
   -- Is_Atomic --
   ---------------

   function Is_Atomic (El : Asis.Element) return Boolean is
      Result : Boolean := False;
   begin
      if Defining_Name_Kind (El) = A_Defining_Identifier then
         Result := Einfo.Is_Atomic (Node (El));
      end if;

      return Result;
   end Is_Atomic;

   -------------------
   -- Is_Concurrent --
   -------------------

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

      if Defining_Name_Kind (El) = A_Defining_Identifier then
         El_Type_Entity := Etype (Node (El));

         if Present (El_Type_Entity)
           and then
            Present (Full_View (El_Type_Entity))
         then
            El_Type_Entity := Full_View (El_Type_Entity);
         end if;

         if Ekind (El_Type_Entity) in E_Array_Type .. E_Array_Subtype then
            El_Type_Entity := Component_Type (El_Type_Entity);

            if Present (El_Type_Entity)
              and then
               Present (Full_View (El_Type_Entity))
            then
               El_Type_Entity := Full_View (El_Type_Entity);
            end if;

         end if;

         if Ekind (El_Type_Entity) in Concurrent_Kind then
            Result := True;
         end if;

      end if;

      return Result;
   end Is_Concurrent;

   ---------------------------------------
   -- Is_Declaration_Of_Callable_Entity --
   ---------------------------------------

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

--      case Declaration_Kind (El) is
--         when A_Procedure_Declaration   |
--              A_Function_Declaration    |
--              A_Procedure_Instantiation |
--              A_Function_Instantiation =>
--            Result := True;

--         when A_Procedure_Body_Stub |
--              A_Function_Body_Stub  =>

--            if Declaration_Kind (Corresponding_Declaration (El)) not in
--                 A_Generic_Declaration
--            then
--               Result := True;
--            end if;

--         when others =>
--            null;
--      end case;

--      return Result;
--   end Is_Declaration_Of_Callable_Entity;

   -----------------------
   -- Is_Of_No_Interest --
   -----------------------

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

      --  Not all the constructs that are of no interest are analyzed below.
      --  For example, we do not look into protected bodies, so we do not care
      --  about entry bodies. We do not look into generics, so we do not care
      --  about generic formal parameters

      case Declaration_Kind (El) is
         when A_Task_Type_Declaration              |
              An_Incomplete_Type_Declaration       |
              A_Tagged_Incomplete_Type_Declaration |
              A_Private_Type_Declaration           |
              A_Single_Task_Declaration            |
              A_Discriminant_Specification         |
              A_Parameter_Specification            |
               --  may comtain initialization expressions
              A_Single_Protected_Declaration       |
              A_Protected_Type_Declaration         |
              A_Protected_Body_Declaration         |
               --  protected objects are considered safe
              A_Generic_Procedure_Declaration      |
              A_Generic_Function_Declaration       |
              A_Generic_Package_Declaration        =>
               --  generics are not executed

            Result := True;

         when A_Procedure_Body_Declaration |
              A_Function_Body_Declaration  |
              A_Package_Body_Declaration   |
              A_Task_Body_Declaration      =>

            --  These constructs are of no interest if they are in a generic
            --  body.

            if Is_Subunit (El) then
               --  We have to traverse a possible chain of "nested" subunits
               Corr_Decl := Corresponding_Body_Stub (El);
               Tmp       := Corresponding_Declaration (Corr_Decl);

               if not Is_Nil (Tmp) then
                  Corr_Decl := Tmp;
               end if;

               if Declaration_Kind (Corr_Decl) in A_Generic_Declaration then
                  Result := True;
               else
                  --  We are in some unit, and we do not know if this
                  --  unit is an executable unit
                  Corr_Decl := Enclosing_Element (Corr_Decl);

                  while not Is_Nil (Corr_Decl) loop
                     Result := Is_Of_No_Interest (Corr_Decl);

                     if Result then
                        exit;
                     else
                        Corr_Decl := Enclosing_Element (Corr_Decl);
                     end if;

                  end loop;

               end if;

            else
               Result := Declaration_Kind (Corresponding_Declaration (El)) in
                 A_Generic_Declaration;
            end if;

         when others =>
            null;
      end case;

      if Element_Kind (El) = An_Expression then
         --  It may be a default initialization expression, it is not executed
         --  at the place where is textually present. The following check is
         --  accurate only if we do not consider at all single protected
         --  objects:

         Tmp := Enclosing_Element (El);

         case Flat_Element_Kind (Tmp) is
            when A_Discriminant_Specification |
                 A_Component_Declaration      |
                 A_Parameter_Specification    =>
               Result := True;

            when An_Entry_Call_Statement =>
               --  We do not analyse prefixes of entry calls!!!

               if Is_Equal (El, Called_Name (Tmp)) then
                  Result := True;
               end if;

            when others =>
               null;
         end case;

      end if;

      return Result;
   end Is_Of_No_Interest;

   ------------------
   -- Is_Protected --
   ------------------

   function Is_Protected (El : Asis.Element) return Boolean is
   begin

      case Declaration_Kind (El) is
         when A_Protected_Type_Declaration   |
              A_Single_Protected_Declaration |
              A_Protected_Body_Declaration   |
              A_Protected_Body_Stub          =>
            return True;
         when others =>
            return False;
      end case;

   end Is_Protected;

   -------------------------------------------
   -- Is_Reference_To_Councurrent_Component --
   -------------------------------------------

   function Is_Reference_To_Councurrent_Component
     (El   : Asis.Element)
      return Boolean
   is
      N      : Node_Id;
      Old_N  : Node_Id;
      Result : Boolean := False;
   begin

      if Expression_Kind (El) = An_Identifier then
         N     := R_Node (El);
         Old_N := N;

         while Nkind (N) in N_Has_Etype
            and then
               (No (Etype (N))
               or else
                Ekind (Etype (N)) in E_Access_Type .. E_Protected_Subtype)
         loop
            Old_N := N;
            N     := Parent (N);
         end loop;

         if Nkind (Old_N) in N_Has_Etype then
            N := Etype (Old_N);

            if No (N) and then Nkind (Parent (Old_N)) = N_Expanded_Name then
               N := Etype (Parent (Old_N));
            end if;

            if Present (N)
              and then
               Present (Full_View (N))
            then
               N := Full_View (N);
            end if;

            Result := Ekind (N) in Concurrent_Kind;

         end if;

      end if;

      return Result;
   end Is_Reference_To_Councurrent_Component;

   --------------
   -- Is_Scope --
   --------------

   function Is_Scope (El : Asis.Element) return Boolean is
      Result : Boolean := False;
   begin
      case Declaration_Kind (El) is
         when A_Procedure_Body_Declaration |
              A_Function_Body_Declaration  |
              A_Task_Body_Declaration      =>
            Result := True;
         when others =>
            null;
      end case;

      return Result;
   end Is_Scope;

   ------------------------
   -- Is_Subprogram_Call --
   ------------------------

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

      Result :=
        Expression_Kind (El) = A_Function_Call
       or else
        Statement_Kind (El) = A_Procedure_Call_Statement;

      return Result;
   end Is_Subprogram_Call;

   -------------------------------------
   -- Look_For_Enclosed_Tasks_Post_Op --
   -------------------------------------

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

   ------------------------------------
   -- Look_For_Enclosed_Tasks_Pre_Op --
   ------------------------------------

   procedure Look_For_Enclosed_Tasks_Pre_Op
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Boolean)
   is
   begin
      case Flat_Element_Kind (Element) is
         when A_Task_Type_Declaration   |
              A_Single_Task_Declaration =>
            State   := True;
            Control := Terminate_Immediately;
         when A_Procedure_Body_Declaration |
              A_Function_Body_Declaration  |
              A_Package_Declaration        |
              A_Package_Body_Declaration   |
              A_Task_Body_Declaration      |
              A_Block_Statement            =>
            null;
         when others =>
            Control := Abandon_Children;
      end case;
   end Look_For_Enclosed_Tasks_Pre_Op;

end Gnatsync.ASIS_Utilities;
