------------------------------------------------------------------------------
--                                                                          --
--                          GNATCHECK COMPONENTS                            --
--                                                                          --
--     G N A T S Y N C . G L O B A L _ I N F O . C A L L _ G R A P H        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                    Copyright (C) 2007-2009, 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 Asis.Declarations;         use Asis.Declarations;
with Asis.Elements;             use Asis.Elements;
with Asis.Extensions;           use Asis.Extensions;

with Asis.Set_Get;              use Asis.Set_Get;

with ASIS_UL.Common;            use ASIS_UL.Common;
with ASIS_UL.Global_State.Utilities;
with ASIS_UL.Output;            use ASIS_UL.Output;
with ASIS_UL.Strings;           use ASIS_UL.Strings;
with ASIS_UL.Utilities;

with Gnatsync.ASIS_Utilities;   use Gnatsync.ASIS_Utilities;
with Gnatsync.Global_Info.Data; use Gnatsync.Global_Info.Data;
with Gnatsync.Threads;          use Gnatsync.Threads;

package body Gnatsync.Global_Info.Call_Graph is

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

   procedure Process_Callable_Entity (El : Asis.Element);
   --  Stores (if needed) in the call graph the information about the
   --  callable entity.

   procedure Process_Renaming_As_Body (El : Asis.Element);
   --  If we have renaming-as-body, this means that we have the corresponding
   --  subprigram deckaration, so - the corresponding node in the call graph.
   --  This subprogram detects (and creates, if needed) the corresponding node
   --  in the call graph and sets for this node Is_Renaming ON. Then in tries
   --  to unwind the renaming, and if the renamed entity can be statically
   --  defined, stores the ID of this entity in the Calls_Chain for the node.
   --  (That is, if we have a subprogram that has renaming-as-body as its
   --  completion, we represent this in the call graph as if this subprogram
   --  calls the renamed subprogram. The case of renaming a task entry as a
   --  subprogram is not implemented yet.) If the renamed entity is a protected
   --  operation, or an enumeration literal or if it cannot be determined
   --  statically, then we do not store anything in the Call_Chain, and we set
   --  Is_Of_No_Interest flag ON for the corresponding node.

   procedure Process_Scope (El : Asis.Element);
   --  Stores in the call graph the information about the scope (that is -
   --  about the body of a callable entity) and updates Current_Scope and
   --  the scope stack.

   procedure Process_Subprogram_Call (El : Asis.Element);
   --  Analyzes a subprogram call. If the call cannot be statically analyzed,
   --  generates the corresponding diagnostic message.

   procedure Store_Arc (Called_Entity : Asis.Element; At_SLOC : String_Loc);
   --  Supposing that Called_Entity is an Element that can be stored as a node
   --  of the Call Graph (that is, Corresponding_Element has already been
   --  applied to it), stores the call arc from the current scope to the node
   --  corresponding to this element using At_SLOC as the SLOC of the place
   --  where the call takes place. Only one (the first) call from the scope to
   --  the given Element is stored.

   -----------------------------
   -- Collect_Call_Graph_Info --
   -----------------------------

   procedure Collect_Call_Graph_Info (El : Element) is
   begin

      if Is_Scope (El) then
         Process_Scope (El);

      elsif ASIS_UL.Global_State.Utilities.
        Is_Declaration_Of_Callable_Entity (El)
      then
         Process_Callable_Entity (El);

      elsif Asis.Extensions.Is_Renaming_As_Body (El) then
         Process_Renaming_As_Body (El);

         --  At the moment, we just inwind renamings to the called subprogram
      elsif Is_Subprogram_Call (El) then
         Process_Subprogram_Call (El);
      end if;

   end Collect_Call_Graph_Info;

   ------------------------------
   -- Complete_Call_Graph_Info --
   ------------------------------

   procedure Complete_Call_Graph_Info (El : Asis.Element) is
   begin

      if Is_Scope (El) then
         Remove_Current_Scope;
      end if;

   end Complete_Call_Graph_Info;

   -----------------------------
   -- Process_Callable_Entity --
   -----------------------------

   procedure Process_Callable_Entity (El : Asis.Element) is
      Tmp : GS_Node_Id;
      pragma Unreferenced (Tmp);
   begin
      Tmp := Corresponding_Node (El, Current_Scope);
   end Process_Callable_Entity;

   ------------------------------
   -- Process_Renaming_As_Body --
   ------------------------------

   procedure Process_Renaming_As_Body (El : Asis.Element) is
      Subprogram_Node : constant GS_Node_Id :=
        Corresponding_Node (Corresponding_Declaration (El));

      Renamed_Subprogram : constant Asis.Element :=
        Get_Renamed_Subprogram (El);

      Renamed_Subprogram_Node : GS_Node_Id;

      Is_Of_No_Interest : Boolean := True;
   begin
      Set_Is_Renaming (Subprogram_Node);

      case Declaration_Kind (Renamed_Subprogram) is

         when A_Procedure_Body_Declaration |
              A_Function_Body_Declaration  |
              A_Procedure_Body_Stub        |
              A_Function_Body_Stub         |
              A_Procedure_Instantiation    |
              A_Function_Instantiation     =>
            Is_Of_No_Interest := False;

         when A_Procedure_Declaration |
              A_Function_Declaration  |
              An_Entry_Declaration    =>

            if Definition_Kind (Enclosing_Element (Renamed_Subprogram)) =
               A_Protected_Definition
            then
               --  Protected operations are safe, so we just keep
               --  Is_Of_No_Interest ON
               null;
            elsif Declaration_Kind (Renamed_Subprogram) =
                  An_Entry_Declaration
            then
               --  Task entry is renamed as a subprogram - we cannot process
               --  this case yet:
               Set_Is_Of_No_Interest (Subprogram_Node);
               raise Non_Implemented_Error;
            else
               Is_Of_No_Interest := False;
            end if;

         when others =>
            --  Is_Of_No_Interest remains ON.
            null;
      end case;

      if Is_Of_No_Interest then
         Set_Is_Of_No_Interest (Subprogram_Node);
      else
         Renamed_Subprogram_Node := Corresponding_Node (Renamed_Subprogram);
         Store_Call_Arc
           (Called_Link  => (Node => Renamed_Subprogram_Node,
                             SLOC => Build_GNAT_Location (El)),
            Calling_Node => Subprogram_Node);
      end if;

   end Process_Renaming_As_Body;

   -------------------
   -- Process_Scope --
   -------------------

   procedure Process_Scope (El : Asis.Element) is
      Tmp      : GS_Node_Id;
      Scope_El : Asis.Element;
   begin
      Scope_El := Corresponding_Element (El);
      Tmp      := Corresponding_Node (Scope_El, Current_Scope);

      if Declaration_Kind (El) = A_Task_Body_Declaration
        and then
          Declaration_Kind (Corresponding_Declaration (Scope_El)) =
            A_Task_Type_Declaration
      then
         --  Task type differs from a single anonymiosily typed task object in
         --  respect of the scope node. For a task object, the front-end
         --  creates an inplicit task type using the defining identifier node
         --  from the task body as the defining identifier node for this type,
         --  so the defining identifier from the body works as a top of the
         --  scope for bodies corresponding to single task declarations. But
         --  for a body that corresponds to a task type we have to go to the
         --  task type declaration to get the scope node.

         Scope_El := Corresponding_Declaration (Scope_El);
      end if;

      Scope_El := First_Name (Scope_El);

      Set_Current_Scope (Tmp, Node (Scope_El));
      Set_Body_Analyzed (Tmp);
   end Process_Scope;

   -----------------------------
   -- Process_Subprogram_Call --
   -----------------------------

   procedure Process_Subprogram_Call (El : Asis.Element) is
      Called_El                  : Asis.Element   := Get_Called_Element (El);
      Critical_Section_Border_Id : Thread_Info_Id := No_Thread_Info;

   begin

      if Is_Implicit_Neq_Declaration (Called_El) then
         Called_El := Corresponding_Equality_Operator (Called_El);
      end if;

      if Is_Nil (Called_El) then

         if ASIS_UL.Global_State.Utilities.Is_Call_To_Predefined_Operation (El)
           or else
            ASIS_UL.Utilities.Is_Call_To_Attribute_Subprogram (El)
         then
            --  We do not consider such calls at all
            return;
         else
            Warning (Build_GNAT_Location (El) &
                   ": call can not be resolved statically");
         end if;

      elsif Declaration_Kind (Called_El) =
            An_Enumeration_Literal_Specification
      then
         --  This may happen in instantiation if an enumeration literal is
         --  used as an actual for a formal function.
         return;
      else

         if ASIS_UL.Global_State.Utilities.Is_Predefined_Operation_Renaming
              (Called_El)
         then
            --  We do not consider such calls at all
            return;
         end if;

         Called_El := Corresponding_Element (Called_El);

         if Is_Nil (Called_El) then
            --  The only known reason is that subprogram renaming cannot be
            --  resolved statically, so diagnstic should be generated
            Warning (Build_GNAT_Location (El) &
                   ": call can not be resolved statically");

            return;
         elsif Expression_Kind (Called_El) = An_Attribute_Reference
              or else
               Expression_Kind (Called_El) = An_Enumeration_Literal
              or else
               Declaration_Kind (Called_El) = A_Null_Procedure_Declaration
              or else
               Definition_Kind (Enclosing_Element (Called_El)) =
                 A_Protected_Definition
         then
            --  These calls are of no interest
            return;
         end if;

         pragma Assert
           (ASIS_UL.Global_State.Utilities.
              Is_Declaration_Of_Callable_Entity (Called_El)
           or else
            Is_Scope (Called_El));

         if Foreign_Critical_Sections_Specified
           and then
            Statement_Kind (El) = A_Procedure_Call_Statement
         then
            Critical_Section_Border_Id := Get_Section_Border_Id (Called_El);

            if Thread_Info_Kind (Critical_Section_Border_Id) =
               Section_Start
            then
               Store_Section_Start (Critical_Section_Border_Id);
            end if;

         end if;

         if No (Critical_Section_Border_Id) then
            --  We do not include in the call graph calls to the section
            --  start/stop procedures

            Store_Arc
              (Called_Entity => Called_El,
               At_SLOC       => Build_GNAT_Location (El));
         end if;

      end if;

   end Process_Subprogram_Call;

   ---------------
   -- Store_Arc --
   ---------------

   procedure Store_Arc (Called_Entity : Asis.Element; At_SLOC : String_Loc) is
      Called_Node : constant GS_Node_Id := Corresponding_Node (Called_Entity);
   begin
      pragma Assert (Present (Called_Node));
      Store_Call_Arc (Called_Link => (Node => Called_Node, SLOC => At_SLOC));
   end Store_Arc;

end Gnatsync.Global_Info.Call_Graph;
