------------------------------------------------------------------------------
--                                                                          --
--                          GNATCHECK COMPONENTS                            --
--                                                                          --
--             G N A T C H E C K . G L O B A L _ S T A T E . C G            --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2005-2006, 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).             --
--                                                                          --
------------------------------------------------------------------------------

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;            use Asis.Extensions;
with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds;
with Asis.Statements;            use Asis.Statements;

with ASIS_UL.Options;
with ASIS_UL.Output;             use ASIS_UL.Output;

with Gnatcheck.ASIS_Utilities; use Gnatcheck.ASIS_Utilities;
with Gnatcheck.Rules.Traversing;

package body Gnatcheck.Global_State.CG is

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

   procedure Check_CG_Completeness;
   --  Checks if the information stored in the global data structure is
   --  complete and allows to construct the full Call Graph. Generates a
   --  diagnostic message each time when some incompleteness is detected.

   procedure Traverse_Renamings;
   --  This procedure goes trough all the Call Graph nodes and sets or updates
   --  (direct) call/caller chains for subprogram renaming entities and for
   --  subprogram entities that have renaming-as-body as completion. See the
   --  body of Gnatcheck.Global_State for full documentation of representing
   --  renamiings in global structure

   procedure Traverse_Concurrent_Nodes;
   --  This procedure goes trough all the Call Graph nodes and sets call chain
   --  for the nodes representing task objects and protected operations from
   --  the call set of the corresponding task definition and executable
   --  protected operation nodes.

   procedure Process_Call (Call : Asis.Element);
   --  For the argument that should be Gnatcheck.Asis_Utilities.Is_Call,
   --  analyzes the call, tries to locate a called entity and creates the
   --  corresponding arc in the call graph. Each arc is stored only once. If
   --  the called entity cannot  be defined, creates a special arc that
   --  describes why the called entity cannot  be located.
   --
   --  ??? (More comments should be added, see F912-025)

   procedure Process_Task_Entry_Call (Call : Asis.Element);
   procedure Process_Protected_Operation_Call (Call : Asis.Element);
   procedure Process_Ordinary_Call (Call : Asis.Element);
   --  Each of these three procedures implements the corresponding part of
   --  the functionality of Process_Call
   --
   --  ??? (More comments should be added, see F912-025)

   procedure Process_Elab_Calls
     (El      : Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State);
   --  For the argument that should be
   --  Gnatcheck.Asis_Utilities.May_Contain_Elab_Calls, analyzes the argument,
   --  tries to find implicit calls that are made during the elaboration and
   --  for each of these calls processes this call as a regular call.

   procedure Process_Renaming (El : Asis.Element);
   --  Provided that Is_Renaming (El), analyzed El and creates the
   --  corresponding structures in the call graph.
   --  More details???
   --  See the body of Gnatcheck.Global_State for full documentation of
   --  representing renamiings in global structure

   procedure Store_Dispatching_Call;
   --  Stores for the current scope the arc representing the dispatching call.
   --  This arc is stored only once for every caller node.
   --  Is this the right place for declaring this procedure?

   procedure Store_Dynamic_Call;
   --  Stores for the current scope the arc representing the dynamic call.
   --  This arc is stored only once for every caller node.
   --  Is this the right place for declaring this procedure?

   function Get_Worst_SE (From_Set : Call_Lists.Set) return GS_Node_Id;
   --  For the nodes stored in From_Set (this function suppeses that From_Set
   --  is not empty) defines and returns as a result the node contained in this
   --  set and having the most serious side effect.

   -----------------
   -- Add_CG_Info --
   -----------------

   procedure Add_CG_Info
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State)
   is
      Tmp : GS_Node_Id;
   begin

      --  Is_Scope (Element) can also have elaboration calls, so we have to
      --  process elaboration calls in a separate IF statement
      if Can_Have_Elab_Calls (Element) then
         Process_Elab_Calls (Element, Control, State);
      end if;

      if Is_Exec_Call (Element) then
         Process_Call (Element);
      elsif Is_Task_Creation (Element) then
         Store_Task_Creation_Arc (Element);
      elsif Is_Scope (Element) then
         Tmp := Register_Entity (Element);
         Set_Current_Scope (Tmp);
         Set_Is_Scope (Tmp);
--         GS_Nodes.Table (Tmp).Is_Scope := True;
      elsif Is_Caller (Element)
        or else
            Definition_Kind (Element) in
              A_Task_Definition .. A_Protected_Definition
      then
         Tmp := Register_Entity  (Element, Fix_Protected_Op => True);
         Set_Enclosing_Scope (Tmp);
      elsif Is_Renaming (Element) then
         Process_Renaming (Element);
      end if;

   end Add_CG_Info;

   ---------------------------
   -- Check_CG_Completeness --
   ---------------------------

   procedure Check_CG_Completeness is
   begin

      --  First, set Body_Analyzed for task objects abd protected operations
      --  in case if the corresponding body is processed (for tasks and
      --  protected objects declared by an object declarations)

      for J in First_GS_Node .. GS_Nodes.Last loop

         if (GS_Node_Kind (J) = A_Task_Object
            and then
             Body_Analyzed (Get_Task_Definition (J)))
           or else
            (GS_Node_Kind (J) in A_Protected_Procedure .. A_Protected_Entry
            and then
             Body_Analyzed (Get_Protected_Op (J)))
         then
            Set_Body_Analyzed (J, True);
         end if;

      end loop;

      for J in First_GS_Node .. GS_Nodes.Last loop

         if not Body_Analyzed (J) then
            Error ("body is not analyzed for " & Get_String (Location (J)));
         end if;

      end loop;

   end Check_CG_Completeness;

   ----------------------
   -- Complete_CG_Info --
   ----------------------

   procedure Complete_CG_Info (El : Asis.Element) is
   begin

      if Is_Scope (El) then
         Remove_Current_Scope;
      end if;

   end Complete_CG_Info;

   ------------------
   -- Get_Worst_SE --
   ------------------
   function Get_Worst_SE (From_Set : Call_Lists.Set) return GS_Node_Id is
      Next_Node : Call_Lists.Cursor := Call_Lists.First (From_Set);
      Result    : GS_Node_Id        := Call_Lists.Element (Next_Node);

      Current_SE       : Side_Effect_Statuses := Side_Effect_Status (Result);
      Current_SE_Level : Scope_Levels;
   begin
      if Current_SE = Local_Side_Effect then
         Current_SE_Level := Local_Side_Effect_Level (Result);
      end if;

      while Call_Lists.Has_Element (Next_Node) loop

         if Current_SE <
              Side_Effect_Status (Call_Lists.Element (Next_Node))
           or else
            (Current_SE = Local_Side_Effect
            and then
             Current_SE = Side_Effect_Status (Call_Lists.Element (Next_Node))
            and then
             Current_SE_Level >
               Local_Side_Effect_Level (Call_Lists.Element (Next_Node)))
         then
            Result     := Call_Lists.Element (Next_Node);
            Current_SE := Side_Effect_Status (Result);

            if Current_SE = Local_Side_Effect then
               Current_SE_Level := Local_Side_Effect_Level (Result);
            end if;

         end if;

         Next_Node := Call_Lists.Next (Next_Node);
      end loop;

      return Result;
   end Get_Worst_SE;

   ---------------
   -- Is_Called --
   ---------------

   function Is_Called (N : GS_Node_Id) return Boolean is
   begin
      pragma Assert (Present (N));

      return GS_Nodes.Table (N).Is_Used;
   end Is_Called;

   ------------------
   -- Process_Call --
   ------------------

   procedure Process_Call (Call : Asis.Element) is
   begin

      if Is_Task_Entry_Call (Call) then
         Process_Task_Entry_Call (Call);
      elsif Is_Protected_Operation_Call (Call) then
         Process_Protected_Operation_Call (Call);
      else
         Process_Ordinary_Call (Call);
      end if;
   end Process_Call;

   ------------------------
   -- Process_Elab_Calls --
   ------------------------

   procedure Process_Elab_Calls
     (El      : Asis.Element;
      Control : in out Traverse_Control;
      State   : in out Rule_Traversal_State)
   is
      Type_Decl_El : Asis.Element := Nil_Element;
      --  To be set to point to the (full) type declaration of the type
      --  for that we have to process default (sub)component initialization
      --  expressions

      Process_Discriminants : Boolean := False;
      --  In case if the discriminant constraint is present, we do not have to
      --  process default expressions for discriminants

      procedure Process_Type_Elab_Code
        (El                    : Asis.Element;
         Process_Discriminants : Boolean);
      --  Collects the call graph information from all the possible component
      --  initialization expression, recursevely traversing the type structure
      --  of the type declaration represented by El. Initialization expressions
      --  for discrimitatnts are processed only if Process_Discriminants is ON.

      procedure Process_Type_Elab_Code
        (El                    : Asis.Element;
         Process_Discriminants : Boolean)
      is
         Type_Components : constant Asis.Element_List :=
           Get_Type_Components (El, Process_Discriminants);
         --  List of the component declarations elaborated as a part of the
         --  elaborating of the type declaration

         Expr : Asis.Element;
         --  Initialization expression of the componment

         Comp_Type : Asis.Element;
         --  If we have an array, we have to investigate the component type as
         --  well
      begin

         if Is_Nil (Type_Components) then

            --  The only possibility that can be of interest for us is an array
            --  type with record components (including possible derivations)

            Comp_Type := Type_Declaration_View (El);

            if Type_Kind (Comp_Type) = A_Derived_Type_Definition then
               --  Note, that we do not care about
               --  A_Derived_Record_Extension_Definition here, because
               --  for them we should get both explicit and implicit components
               --  from the call to Get_Type_Components. We also do not care
               --  about possible discriminant constraints here

               Comp_Type := Corresponding_Root_Type (Comp_Type);
               Comp_Type :=  Type_Declaration_View (Comp_Type);
            end if;

            if Type_Kind (Comp_Type) in
               An_Unconstrained_Array_Definition ..
               A_Constrained_Array_Definition
            then
               Comp_Type :=
                 Component_Subtype_Indication
                   (Array_Component_Definition (Comp_Type));

               Comp_Type := Asis.Definitions.Subtype_Mark (Comp_Type);

               if Expression_Kind (Comp_Type) /= An_Attribute_Reference then
                  Comp_Type := Get_Type_Decl_From_Subtype_Mark (Comp_Type);

                  if Declaration_Kind (Comp_Type) /=
                     A_Task_Type_Declaration
                  then
                     --  It can be no elaboration code for task type!
                     Process_Type_Elab_Code
                       (Comp_Type, Process_Discriminants => False);

                  end if;

               end if;

            end if;

         else

            for J in Type_Components'Range loop
               Expr := Initialization_Expression (Type_Components (J));

               if Is_Nil (Expr) then
                  --  But the component type may contain initialization
                  --  expressions! The component itself should have a definite
                  --  subtype, so there is no need to analyse component
                  --  discriminants
                  Comp_Type :=
                    Component_Subtype_Indication
                      (Object_Declaration_View (Type_Components (J)));

                  Comp_Type := Asis.Definitions.Subtype_Mark (Comp_Type);

                  if Expression_Kind (Comp_Type) /= An_Attribute_Reference then
                     Comp_Type := Get_Type_Decl_From_Subtype_Mark (Comp_Type);

                     if Declaration_Kind (Comp_Type) /=
                        A_Task_Type_Declaration
                     then
                        --  It can be no elaboration code for task type!
                        Process_Type_Elab_Code
                          (Comp_Type, Process_Discriminants => False);

                     end if;

                  end if;

               else
                  Gnatcheck.Rules.Traversing.Extract_Global_Information
                    (Element => Expr,
                     Control => Control,
                     State   => State);
               end if;

            end loop;

         end if;

      end Process_Type_Elab_Code;

   begin

      case Flat_Element_Kind (El) is
         when A_Variable_Declaration =>

            if Is_Nil (Initialization_Expression (El)) then

               Type_Decl_El := Object_Declaration_View (El);

               if Definition_Kind (Type_Decl_El) = A_Type_Definition  then
                  --  The case of A : array (...) of ...
                  Type_Decl_El :=
                    Component_Subtype_Indication
                      (Array_Component_Definition (Type_Decl_El));

                  --  Components should have a definite subtype, so
                  Process_Discriminants := False;
               else
                  Process_Discriminants :=
                     Is_Nil (Subtype_Constraint (Type_Decl_El))
                    and then
                     Is_Indefinite_Subtype
                       (Asis.Definitions.Subtype_Mark (Type_Decl_El));
               end if;

               --  We can not have A_Component_Definition, A_Task_Definition or
               --  A_Protected_Definition case here, because we started from
               --  A_Variable_Declaration so now A_Subtype_Indication is the
               --  only possibility for Type_Decl_El

               Type_Decl_El := Asis.Definitions.Subtype_Mark (Type_Decl_El);

               if Expression_Kind (Type_Decl_El) /=
                     An_Attribute_Reference
               then
                  --  In case of a attribute reference as a subtype mark the
                  --  only possible case is 'Base, so we have a scalar type
                  --  here, therefore it can be no default initialization

                  Type_Decl_El :=
                    Get_Type_Decl_From_Subtype_Mark (Type_Decl_El);

                  if Declaration_Kind (Type_Decl_El) /=
                     A_Task_Type_Declaration
                  then
                     --  It can be no elaboration code for task type!
                     Process_Type_Elab_Code
                       (Type_Decl_El, Process_Discriminants);

                  end if;

               end if;

            end if;

--         when  =>
         when others =>
            --  For all the other cases - Placeholder for the moment !!! ???
            null;
      end case;

   end Process_Elab_Calls;

   ---------------------------
   -- Process_Ordinary_Call --
   ---------------------------

   procedure Process_Ordinary_Call (Call : Asis.Element) is
      Called_El : Asis.Element := Get_Called_Element (Call);
   begin
      if Is_Nil (Called_El) then

         if Is_Call_To_Predefined_Operation (Call)
           or else
            Is_Call_To_Attribute_Subprogram (Call)
         then
            --  We do not consider such calls at all
            return;
         elsif Is_Dispatching_Call (Call) then
            Store_Dispatching_Call;
         elsif Is_Dynamic_Call (Call) then
            Store_Dynamic_Call;
         else
            pragma Assert (False);
            null;
         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
         Called_El := Corresponding_Element (Called_El);

         if not Is_Predefined_Operation_Renaming (Called_El) then
            Store_Arc (Called_El);
         end if;

      end if;

   end Process_Ordinary_Call;

   --------------------------------------
   -- Process_Protected_Operation_Call --
   --------------------------------------

   procedure Process_Protected_Operation_Call (Call : Asis.Element) is
      Protectes_Op  : Asis.Element;
      Protectes_Obj : Asis.Element;
      --  In case of a protected operation call, we have to detect both the
      --  called protected operation and the protected object this operation
      --  belongs to.

      Protected_Op_Node : GS_Node_Id;
      --  Should be set to the body entity of the corresponding protected
      --  operation

      Called_Entity : GS_Node_Id;
      --  Should be set to the entity representing the concrete (that is -
      --  belonging to a specific protected object) protected operation that
      --  is called

   begin

      if Call_To_Complicated_Cuncurrent_Structure (Call) then
         --  We just ignore calls we cannot statically extract any useful info
         --  from
         return;
      end if;

      if Expression_Kind (Call) = A_Function_Call then
         Protectes_Op := Corresponding_Called_Function (Call);
      else
         Protectes_Op := Corresponding_Called_Entity (Call);
      end if;

      Protected_Op_Node := Corresponding_Node (Protectes_Op);

      Protectes_Obj := Corresponding_Protected_Object (Call);

      pragma Assert (not (Is_Nil (Protectes_Obj)));

      --  If Is_Nil (Protectes_Obj), then we have to store a dynamic (???) call
      --  here

      Called_Entity := Corresponding_Protected_Op_Node
        (Protectes_Obj, Protected_Op_Node);

      Store_Arc (Called_Entity);
   end Process_Protected_Operation_Call;

   ----------------------
   -- Process_Renaming --
   ----------------------

   procedure Process_Renaming (El : Asis.Element) is
      Renaming_Node : GS_Node_Id;
   begin

      if Is_Predefined_Operation_Renaming (El) then
         return;
      end if;

      Renaming_Node := Corresponding_Node (Corresponding_Declaration (El));

      Set_Renaming_Node (Renaming_Node, El);

   end Process_Renaming;

   -----------------------------
   -- Process_Task_Entry_Call --
   -----------------------------

   procedure Process_Task_Entry_Call (Call : Asis.Element) is
   begin

      if not Call_To_Complicated_Cuncurrent_Structure (Call) then
         --  We just ignore calls we cannot statically extract any useful info
         --  from
         Process_Ordinary_Call (Call);
      end if;

   end Process_Task_Entry_Call;

   --------------------
   -- Set_Priorities --
   --------------------

   procedure Set_Priorities is
      procedure Set_Node_Priority (N : GS_Node_Id);
      --  Defines the priority for the argument node (it is supposed that this
      --  priority is not defined at the moment of the call). As a side effect
      --  can define priorities for the nodes upon that the priority of the
      --  given node depends upon

      procedure Set_Node_Priority (N : GS_Node_Id) is
         P : GS_Node_Id;
         --  This is the node to take (inherit) the priority from
      begin

         case GS_Node_Kind (N) is

            when A_Protected_Procedure .. A_Protected_Entry =>
               P := Get_Protected_Op (N);

            when A_Protected_Procedure_Body .. A_Protected_Entry_Body =>
               P := Enclosing_Protected_Definition (N);
            when A_Task_Object =>
               P := Get_Task_Definition (N);

            when others =>
               P := Enclosing_Scope (N);
         end case;

         if not Priority_Defined (P) then
            Set_Node_Priority (P);
         end if;

         Set_Priority (N, Node_Priority (P));

      end Set_Node_Priority;

   begin

      for J in First_GS_Node .. GS_Nodes.Last loop

         if not Priority_Defined (J) then
            Set_Node_Priority (J);
         end if;

      end loop;

   end Set_Priorities;

   ---------------------
   -- Set_Side_Effect --
   ---------------------

   procedure Set_Side_Effect is

      procedure Set_SE_Step (State_Changed : out Boolean);
      --  This procedure traverses all the call graph nodes and tries to define
      --  completely a side effect for a node on the base of analysing its
      --  called nodes. State_Changed is set ON if at least for one node
      --  it changes the Side_Effect_Defined status from OFF to ON, otherwise
      --  it is set OFF.

      procedure Resolve_Recursion (State_Changed : out Boolean);
      --  This procedure trues to resolve the side effect settings for
      --  recursive call chains. (That is, if P calls P, we do not know what is
      --  side effect status of P, because P calls a subprogram with unknown
      --  side effect. This routine tries to resolve such situations).
      --  State_Changed is set ON if the side effect is set for at least one
      --  recursive chain.

      procedure Set_Task_Objects_and_Renamings;
      --  This procedure copies into a task object the side effect data from
      --  the corresponding task definition, and in the renaming objects -
      --  the corresponding data from the renamed object

      State_Changed : Boolean := True;
      --  This flag indicates if there is any sense to continue iterations
      --  through nodes in order to detect the side effect for some other node.
      --  If this flag is OFF, we can not do anything else.

      Recursive_Set : Call_Lists.Set;
      --  ???

      -----------------------
      -- Resolve_Recursion --
      -----------------------

      procedure Resolve_Recursion (State_Changed : out Boolean) is
         procedure Resolve_SE_For_Node (N : GS_Node_Id);
         --  Resolves the side effect for the recursive chain containing N

         procedure Resolve_SE_For_Node (N : GS_Node_Id) is
            Worst_SE_Node   : GS_Node_Id;
            Can_Resolve_SE  : Boolean := True;
            --  We can resolve the side effect for a given set of recursive
            --  nodes if for any node from this set any call to a node with
            --  unknown side effect is a call to some element from this set.

            Next_In_Chain    : Call_Lists.Cursor;
            Next_Called_Node : GS_Node_Id;
         begin

            Build_Recursive_Chain (N, Recursive_Set);

            --  Compute Can_Resolve_SE:

            Next_In_Chain := Call_Lists.First (Recursive_Set);

            Check_Recursive_Set : while Call_Lists.Has_Element (Next_In_Chain)
            loop
               Reset_Itrerator
                 (For_Node => Call_Lists.Element (Next_In_Chain),
                  Call_Set => Calls);

               Next_Called_Node := Next_Node;

               while Present (Next_Called_Node) loop

                  if not Side_Effect_Defined (Next_Called_Node)
                    and then
                     not Call_Lists.Contains (Recursive_Set, Next_Called_Node)
                  then
                     Can_Resolve_SE := False;
                     exit Check_Recursive_Set;
                  end if;

                  Next_Called_Node := Next_Node;
               end loop;

               Next_In_Chain := Call_Lists.Next (Next_In_Chain);
            end loop Check_Recursive_Set;

            if Can_Resolve_SE then

               Worst_SE_Node := Get_Worst_SE (Recursive_Set);

               Next_In_Chain := Call_Lists.First (Recursive_Set);

               while Call_Lists.Has_Element (Next_In_Chain) loop
                  Correct_Side_Effect_Status
                    (For_Node  => Call_Lists.Element (Next_In_Chain),
                     From_Node => Worst_SE_Node);

                  Set_Side_Effect_Defined (Call_Lists.Element (Next_In_Chain));

                  Next_In_Chain := Call_Lists.Next (Next_In_Chain);
               end loop;

               State_Changed := True;
            end if;

         end Resolve_SE_For_Node;

      begin
         State_Changed := False;

         for J in First_GS_Node .. GS_Nodes.Last loop

            if not Side_Effect_Defined (J)
              and then
               Is_Recursive_Node (J)
            then
               pragma Assert (Call_To_Unknown_SE (J));
               Resolve_SE_For_Node (J);
            end if;

         end loop;

      end Resolve_Recursion;

      -----------------
      -- Set_SE_Step --
      -----------------

      procedure Set_SE_Step (State_Changed : out Boolean) is
         Next_Called_Node       : GS_Node_Id;
         State_Changed_For_Node : Boolean;
      begin

         State_Changed := False;

         for J in First_GS_Node .. GS_Nodes.Last loop

            if not Side_Effect_Defined (J) then

               case GS_Node_Renaming_Kind (J) is
                  when Enum_Literal_Renaming =>
                     --  It can be no side effect in this case!
                     Set_Side_Effect_Defined (J);
                     Set_Side_Effect_Status (J, No_Side_Effect);
                     State_Changed := True;

                  when Renaming_As_Body        |
                       Renaming_As_Declaration |
                       Pass_Actual_Subprogram  =>

                     if Side_Effect_Defined (Renamed_Entity (J)) then
                        Correct_Side_Effect_Status
                          (For_Node  => J,
                           From_Node => Renamed_Entity (J));

                        Set_Side_Effect_Defined (J);
                        State_Changed := True;
                     end if;

                  when Not_A_Renamimg =>

                     if GS_Node_Kind (J) = A_Task_Object then

                        if Side_Effect_Defined (Get_Task_Definition (J)) then
                           Correct_Side_Effect_Status
                             (For_Node  => J,
                              From_Node => Get_Task_Definition (J));

                           Set_Side_Effect_Defined (J);
                           State_Changed := True;
                        end if;

                     elsif GS_Node_Kind (J) in
                       A_Protected_Procedure .. A_Protected_Entry
                     then

                        if Side_Effect_Defined (Get_Protected_Op (J)) then
                           Correct_Side_Effect_Status
                             (For_Node  => J,
                              From_Node => Get_Protected_Op (J));

                           Set_Side_Effect_Defined (J);
                           State_Changed := True;
                        end if;

                     elsif GS_Node_Kind (J) = A_Protected_Definition then
                        Set_Side_Effect_Defined (J);
                        Set_Side_Effect_Status (J, No_Side_Effect);
                        State_Changed := True;

                     elsif not Body_Analyzed (J) then
                        --  We can not do any analysis if we do not have a body
                        Set_Side_Effect_Status (J, Call_To_Missing_Body);
                        Set_Side_Effect_Defined (J);
                        State_Changed := True;
                     else

                        pragma Assert
                          (Body_Analyzed (J)
                          and then
                           Call_To_Unknown_SE (J));

                        State_Changed_For_Node := True;

                        Reset_Itrerator
                          (For_Node => J, Call_Set => Calls);
                        Next_Called_Node := Next_Node;

                        while Present (Next_Called_Node) loop

                           if Side_Effect_Defined (Next_Called_Node) then

                              Correct_Side_Effect_Status
                                (For_Node  => J,
                                 From_Node => Next_Called_Node);

                           elsif J /= Next_Called_Node then
                              State_Changed_For_Node := False;
                              exit;
                           end if;

                           Next_Called_Node := Next_Node;
                        end loop;

                        if State_Changed_For_Node then
                           State_Changed := True;
                           Set_Side_Effect_Defined (J);
                           Set_Call_To_Unknown_SE (J, False);
                        end if;

                     end if;

               end case;

            end if;

         end loop;

      end Set_SE_Step;

      ------------------------------------
      -- Set_Task_Objects_and_Renamings --
      ------------------------------------

      procedure Set_Task_Objects_and_Renamings is
         procedure Copy_Renamed_SE (N : GS_Node_Id);
         --  Copies the side effect through the renaming chain ended with N

         procedure Copy_Renamed_SE (N : GS_Node_Id) is
            R : constant GS_Node_Id := Renamed_Entity (N);
         begin

            if GS_Node_Renaming_Kind (R) /= Not_A_Renamimg then
               Copy_Renamed_SE (R);
            end if;

            Correct_Side_Effect_Status
              (For_Node  => N,
               From_Node => R);

            Set_Side_Effect_Defined (N, Side_Effect_Defined (R));

         end Copy_Renamed_SE;

      begin
         for J in First_GS_Node .. GS_Nodes.Last loop

            if not Side_Effect_Defined (J) then

               if GS_Node_Kind (J) = A_Task_Object then
                  Correct_Side_Effect_Status
                    (For_Node  => J,
                     From_Node => Get_Task_Definition (J));

                  Set_Side_Effect_Defined
                   (J, Side_Effect_Defined (Get_Task_Definition (J)));

               elsif GS_Node_Renaming_Kind (J) /= Not_A_Renamimg then
                  Copy_Renamed_SE (J);
               end if;

            end if;

         end loop;

      end Set_Task_Objects_and_Renamings;

   begin

      while State_Changed loop

         while State_Changed loop
            Set_SE_Step (State_Changed);
         end loop;

         Resolve_Recursion (State_Changed);
      end loop;

      Set_Task_Objects_and_Renamings;

      for J in First_GS_Node .. GS_Nodes.Last loop

         if not (Side_Effect_Defined (J))
           and then
            ASIS_UL.Options.Debug_Mode
         then
            Error ("Side effect is not defined for the node");
            Print_Node (J, Extended_Debug_Image => True);
         else
            --  For the development period only!
            pragma Assert (Side_Effect_Defined (J));
            null;
         end if;

      end loop;

   end Set_Side_Effect;

   -----------------------
   -- Set_Used_Entities --
   -----------------------

   procedure Set_Used_Entities is

      procedure Set_Used_Step (State_Changed : out Boolean);
      --  This procedure traverses all the call graph nodes and sets for a node
      --  Is_Used flag ON. State_Changed is set ON if at least for one node
      --  Is_Used flag is set ON, otherwise it is set OFF.

      State_Changed : Boolean := True;

      procedure Set_Used_Step (State_Changed : out Boolean) is
         Next_Caller_Node : GS_Node_Id;
      begin

         State_Changed := False;

         for J in First_GS_Node .. GS_Nodes.Last loop

            if not GS_Nodes.Table (J).Is_Used then

               Reset_Itrerator (For_Node => J, Call_Set => Callers);
               Next_Caller_Node := Next_Node;

               while Present (Next_Caller_Node) loop

                  if GS_Nodes.Table (Next_Caller_Node).Is_Used then
                     GS_Nodes.Set_Is_Used (J);
                     State_Changed := True;
                     exit;
                  end if;

                  Next_Caller_Node := Next_Node;
               end loop;

            end if;

         end loop;

      end Set_Used_Step;

   begin

      while State_Changed loop
         Set_Used_Step (State_Changed);
      end loop;

   end Set_Used_Entities;

   ----------------------------
   -- Store_Dispatching_Call --
   ----------------------------

   procedure Store_Dispatching_Call is
   begin
      Set_Contains_Dispatching_Call (Current_Scope);
   end Store_Dispatching_Call;

   ------------------------
   -- Store_Dynamic_Call --
   ------------------------

   procedure Store_Dynamic_Call is
   begin
      Set_Contains_Dynamic_Call (Current_Scope);
   end Store_Dynamic_Call;

   ------------------------
   -- Transitive_Closure --
   ------------------------

   procedure Transitive_Closure is

      procedure Init_Matrix;
      --  Creates and initialized Gnatcheck.Global_State.Matrix. This Matrix
      --  should later be used as a clousure of the graph connectivity matrix
      --  (that is, after performing this closure, each row represents all the
      --  nodes called (directly or indirectly) by the given node, and each
      --  column - all the nodes that calls the given node

      procedure Close_Matrix;
      --  Computes Gnatcheck.Global_State.Matrix as the transitive closure of
      --  the call graph connectivity matrix. After the call to this procedure
      --  Matrix (N1, N2) = True if and only if N1 calls (directly or
      --  indirectly) N2.

      ------------------
      -- Close_Matrix --
      ------------------

      procedure Close_Matrix is
         --  Currently we are using workpile algorythm

         New_Set   : Call_Lists.Set;
         --  A set of nodes that are added to Reach_Set. For each of the nodes
         --  from this set we should analyse its direct calls and then remove
         --  the node fron this set. We stop the loop for the next node when
         --  this set is empty

         Newer_Set : Call_Lists.Set;
         --  Nodes that are added for Reach_Set at the last iteration of the
         --  processing of New_Set for the given node. They should be added to
         --  New_Set to process their direct calls

         Reach_Set : Call_Lists.Set;
         --  This is the set nodes that can be reached from (called by) the
         --  given node, aon each step of the outer loop we compute this set
         --  for the call graph node that is a loop parameter

         Next_Direct_Call : Call_Lists.Cursor;
         Next_Call        : Call_Lists.Cursor;
      begin

         for Node in First_GS_Node .. GS_Nodes.Last loop
            Call_Lists.Clear (New_Set);
            Call_Lists.Clear (Newer_Set);
            Call_Lists.Clear (Reach_Set);

            Call_Lists.Union (Reach_Set, GS_Nodes.Table (Node).Calls_Chain);
            Call_Lists.Union (New_Set,   GS_Nodes.Table (Node).Calls_Chain);

            while not Call_Lists.Is_Empty (New_Set) loop
               Next_Direct_Call := Call_Lists.First (New_Set);

               Next_Call :=
                 Call_Lists.First
                   (GS_Nodes.Table
                     (Call_Lists.Element (Next_Direct_Call)).Calls_Chain);

               while Call_Lists.Has_Element (Next_Call) loop

                  if not Call_Lists.Contains
                    (Reach_Set, Call_Lists.Element (Next_Call))
                  then
                     Call_Lists.Insert
                       (Newer_Set, Call_Lists.Element (Next_Call));
                  end if;

                  Next_Call := Call_Lists.Next (Next_Call);
               end loop;

               Call_Lists.Delete_First (New_Set);

               if not Call_Lists.Is_Empty (Newer_Set) then
                  Call_Lists.Union (Reach_Set, Newer_Set);
                  Call_Lists.Union (New_Set,   Newer_Set);
                  Call_Lists.Clear (Newer_Set);
               end if;

            end loop;

            --  Now, fill in the row corresponding to Node in the transitive
            --  closure of the graph connectivity matrix

            Next_Call := Call_Lists.First (Reach_Set);

            while Call_Lists.Has_Element (Next_Call) loop
               Matrix (Node, Call_Lists.Element (Next_Call)) := True;
               Next_Call := Call_Lists.Next (Next_Call);
            end loop;

         end loop;

      end Close_Matrix;

      --  Below there is a version of Close_Matrix based on Warshall's
      --  algorithm

--    procedure Close_Matrix is
--       type Call_Array is array (First_GS_Node .. GS_Nodes.Last) of Boolean;
--       type Access_Call_Array is access all Call_Array;
--       To, From : Access_Call_Array;

--       function Address_To_Access is new
--         Ada.Unchecked_Conversion
--           (Source => Address,
--            Target => Access_Call_Array);
--    begin

--       for L in First_GS_Node .. GS_Nodes.Last loop

--          for U in First_GS_Node .. GS_Nodes.Last loop

--             if Matrix (U, L) then

--                To := Address_To_Access (Matrix (U, First_GS_Node)'Address);
--                From :=
--                  Address_To_Access (Matrix (L, First_GS_Node)'Address);

--                To.all := To.all or From.all;

--             end if;

--          end loop;

--       end loop;

--    end Close_Matrix;

      -----------------
      -- Init_Matrix --
      -----------------

      procedure Init_Matrix is
--         Next_Call : Call_Lists.Cursor;
      begin
         Matrix :=
           new Matrix_Array
                 (First_GS_Node .. GS_Nodes.Last,
                  First_GS_Node .. GS_Nodes.Last);

         Matrix.all := (others => (others => False));

--         for J in Matrix'First .. Matrix'Last loop
--            Next_Call := Call_Lists.First (GS_Nodes.Table (J).Calls_Chain);

--            while Call_Lists.Has_Element (Next_Call) loop
--               Matrix (J, Call_Lists.Element (Next_Call)) := True;
--               Next_Call := Call_Lists.Next (Next_Call);
--            end loop;

--         end loop;

      end Init_Matrix;

   begin

      Check_CG_Completeness;

      Traverse_Renamings;
      Traverse_Concurrent_Nodes;

      Init_Matrix;
      Close_Matrix;

   end Transitive_Closure;

   -------------------------------
   -- Traverse_Concurrent_Nodes --
   -------------------------------

   procedure Traverse_Concurrent_Nodes is
   begin

      for J in First_GS_Node .. GS_Nodes.Last loop

         if GS_Node_Kind (J) in A_Protected_Procedure .. A_Protected_Entry then

            GS_Nodes.Add_Call_Set
              (To_Node    => J,
               Target_Set => Calls,
               From_Node  => Get_Protected_Op (J),
               Source_Set => Calls);

         elsif GS_Node_Kind (J) = A_Task_Object then

            GS_Nodes.Add_Call_Set
              (To_Node    => J,
               Target_Set => Calls,
               From_Node  => Get_Task_Definition (J),
               Source_Set => Calls);

         end if;

      end loop;

   end Traverse_Concurrent_Nodes;

   ------------------------
   -- Traverse_Renamings --
   ------------------------

   procedure Traverse_Renamings is
      Success : Boolean;
   begin
      --  !!! only prototype implementation !!! ???

      for J in First_GS_Node .. GS_Nodes.Last loop

         if GS_Node_Kind (J) in A_Procedure .. A_Function
           and then
            Present (Renamed_Entity (J))
         then
            --  renaming-as-body
            GS_Nodes.Add_Call_Set
              (To_Node    => J,
               Target_Set => Calls,
               From_Node  => Renamed_Entity (J),
               Source_Set => Calls); --  ???

            GS_Nodes.Add_Node_To_List
              (To_Node     => J,
               Node_To_Add => Renamed_Entity (J),
               Set_To_Add  => Calls,
               Inserted    => Success);

            GS_Nodes.Add_Node_To_List
              (To_Node     => Renamed_Entity (J),
               Node_To_Add => J,
               Set_To_Add  => Callers,
               Inserted    => Success);

         end if;

      end loop;

   end Traverse_Renamings;

end Gnatcheck.Global_State.CG;
