asis_2019.0.0_3ca32fa2/tools/tool_utils/asis_ul-global_state.adb

------------------------------------------------------------------------------
--                                                                          --
--                          GNATCHECK COMPONENTS                            --
--                                                                          --
--                 A S I S _ U L . G L O B A L _ S T A T E
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2007-2018, AdaCore                     --
--                                                                          --
-- Asis Utility Library (ASIS UL) 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 3, or (at your --
-- option)  any later version.  ASIS UL  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 --
-- COPYING3. If not,  go to http://www.gnu.org/licenses for a complete copy --
-- of the license.                                                          --
--                                                                          --
-- ASIS UL is maintained by AdaCore (http://www.adacore.com).               --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2012;

with Ada.Characters.Conversions;     use Ada.Characters.Conversions;
with Ada.Containers.Vectors;
with Ada.Text_IO;                    use Ada.Text_IO;
with Ada.Strings.Fixed;              use Ada.Strings.Fixed;

with GNAT.OS_Lib;                    use GNAT.OS_Lib;
with GNAT.Table;

with Asis.Compilation_Units;         use Asis.Compilation_Units;
with Asis.Declarations;              use Asis.Declarations;
with Asis.Definitions;               use Asis.Definitions;
with Asis.Elements;                  use Asis.Elements;
with Asis.Extensions;                use Asis.Extensions;
with Asis.Extensions.Flat_Kinds;     use Asis.Extensions.Flat_Kinds;
with Asis.Iterator;                  use Asis.Iterator;

with Asis.Set_Get;                   use Asis.Set_Get;

with ASIS_UL.Debug;                  use ASIS_UL.Debug;
with ASIS_UL.Global_State.CG;        use  ASIS_UL.Global_State.CG;
with ASIS_UL.Global_State.CG.Conditions;
with ASIS_UL.Global_State.Utilities; use ASIS_UL.Global_State.Utilities;
with ASIS_UL.Options;
with ASIS_UL.Utilities;              use ASIS_UL.Utilities;

with ASIS_UL.Output;                 use ASIS_UL.Output;

package body ASIS_UL.Global_State is

   ---------------------
   --  Global options --
   ---------------------

   Global_Objects_Accessed : Boolean := False;
   --  Set to True to compute global objects accessed directly or indirectly
   --  by subprograms

   procedure Do_Compute_Global_Objects_Accessed is
   begin
      Global_Objects_Accessed := True;
   end Do_Compute_Global_Objects_Accessed;

   function Compute_Global_Objects_Accessed return Boolean is
   begin
      return Global_Objects_Accessed;
   end Compute_Global_Objects_Accessed;

   -------------------
   -- Data entities --
   -------------------

   Environment_Task_Node_Rec : GS_Node_Record;

   package GS_Nodes_Container is new Ada.Containers.Vectors
      (Index_Type   => Existing_GS_Node_Id,
       Element_Type => GS_Node_Record);
   --  We can not use a hashed container. We need a hash function that works on
   --  ASIS Elements, but we cannot save ASIS Elements in the Container,
   --  because an Element becomes obsolete as soon as its enclosing Context
   --  gets closed. So we have to use "external" hash function onto the vector
   --  structure

   GS_Nodes_Table : GS_Nodes_Container.Vector;
   --  A set of nodes making up the global structure. (With the Table function,
   --  Mimics the Table variable from the instantiation of the GNAT.Table
   --  package)

   -------------------------------------------
   -- Hash table for global structure table --
   -------------------------------------------

   Hash_Num : constant Integer := 2**16;
   --  Number of headers in the hash table. There is no special reason in this
   --  choice.

   Hash_Max : constant Integer := Hash_Num - 1;
   --  Indexes in the hash header table run from 0 to Hash_Num - 1

   subtype Hash_Index_Type is Integer range 0 .. Hash_Max;
   --  Range of hash index values

   Hash_Table : array (Hash_Index_Type) of GS_Node_Id;
   --  The hash table is used to locate existing entries in the nodes table.
   --  The entries point to the first nodes table entry whose hash value
   --  matches the hash code. Then subsequent nodes table entries with the
   --  same hash code value are linked through the Hash_Link fields.

   function Hash (El : Asis.Element) return Hash_Index_Type;
   --  Compute hash code for its argument. At the moment we are using rather
   --  primitive hash function, this should be revised at some point

   -----------------
   -- Scope_Stack --
   -----------------

   subtype Scope_Ind_Type is Natural;

   type Scope_Record is record
      Scope : Scope_Id;
      --  Used to keep stack of enclosed scopes

      Scope_Tree_Node : Node_Id;
      --  reference to the tree node of the corresponding node. (This node is
      --  returned by Einfo.Scope function for the entities defined in this
      --  scope)

   end record;

   package Scope_Stack is new GNAT.Table
     (Table_Component_Type => Scope_Record,
      Table_Index_Type     => Scope_Ind_Type,
      Table_Low_Bound      => 1,
      Table_Initial        => 50,
      Table_Increment      => 100,
      Table_Name           => "scope stack table");

   procedure Set_Scope_Level (N : GS_Node_Id; Val : Positive);
   --  Sets Val as a scope level of N

   ---------------------------------------------------------
   -- Internal global strucure access and update routines --
   ---------------------------------------------------------

   function Find_Node
     (El            : Asis.Element;
      Expected_Kind : GS_Node_Kinds := Not_A_Node)
      return          GS_Node_Id;
   --  Looks for the node corresponding to the given Element in the global data
   --  structure. If Expected_Kind differs from Not_A_Node, looks only for the
   --  nodes of the kind specified by Expected_Kind. Returns No_GS_Node if
   --  there is no such node. Note, that this function assumes that
   --  Corresponding_Element has been applied to its argument before the call.

   function Define_GS_Node_Kind (El : Asis.Element) return GS_Node_Kinds;
   --  Defines which node kind corresponds to the given Element

   function Is_Equal
     (N             : GS_Node_Id;
      El            : Asis.Element;
      Expected_Kind : GS_Node_Kinds := Not_A_Node)
      return          Boolean;
   --  Checks if the Element represented by N is equal to El. If Expected_Kind
   --  differs from Not_A_Node, assumes that the node corresponding to El
   --  should have the specified kind. Returns False if No (N).

   function Register_Node
     (El            : Asis.Element;
      Encl_Scope    : Scope_Id      := No_Scope;
      Expected_Kind : GS_Node_Kinds := Not_A_Node)
      return GS_Node_Id;
   --  Registers the node corresponding to the argument Element and returns its
   --  Id as a result. The caller is responsible for making sure that this
   --  Element has Corresponding_Element has been applied to its argument
   --  Element before the call. If set to non-empty value, Enclosing_Scope
   --  parameter is used to specify the enclosing scope of the node to be
   --  created. If set to a value different from Not_A_Node, Expected_Kind
   --  specifies the kind of the node to be returned.
   --
   --  As a side effect, this function may create some other nodes and links
   --  needed to represent the result node.
   --
   --  This function can never return No_GS_Node.

   function Get_Node_Name
     (El        : Asis.Element;
      Node_Kind : GS_Node_Kinds)
      return      String;
   --  Returns the name of the entity represented by the node in the global
   --  structure. Assumes that El is of A_Defining_Name kind. Depending on
   --  Node_Kind, some suffixes may be appended to the string image of the
   --  defining name.

   function GS_Node_Hash_Link (N : GS_Node_Id) return GS_Node_Id;
   --  Returns the hash link for the argumeny node. Returns No_GS_Node in case
   --  if No (N).

   procedure Set_Hash_Link (N : GS_Node_Id; Val : GS_Node_Id);
   --  Sets the hash link of the node N to Val. It is erroneous to call it for
   --  No (N).

   Ident_String : constant String := "   ";
   --  Used in the debug output of the global data structures

   procedure Collect_Discr_Init_Calls
     (Type_Decl      : Asis.Element;
      Init_Proc_Node : GS_Node_Id);
   --  Analyses the type declarations and stores all the calls issued from
   --  default discriminant initialization expressions as the calls made by
   --  the discriminant initialization procedure. This procedure assumes that
   --  Has_Discr_Init_Proc (Type_Decl) is True, and Init_Proc_Node is the node
   --  corresponding to the discriminant initialization procedure.

   procedure Collect_Type_Init_Calls
     (Type_Decl      : Asis.Element;
      Init_Proc_Node : GS_Node_Id);
   --  Analyses the type declarations and stores all the calls issued from
   --  default component initialization expressions as the calls made by
   --  the type initialization procedure. This procedure assumes that
   --  Has_Type_Init_Proc (Type_Decl) is True, and Init_Proc_Node is the node
   --  corresponding to the discriminant initialization procedure.

   procedure Collect_Component_Calls
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out No_State);
   --  Pre-operation for type definition traversing aimed at extraction of
   --  function calls from default initialization expressions and needed calls
   --  to type initialization procedures for the components which types have
   --  such subprograms.

   procedure Collect_Calls_From_Components is new Traverse_Element
     (State_Information => No_State,
      Pre_Operation     => Collect_Component_Calls,
      Post_Operation    => No_Op);

   ---------
   -- "<" --
   ---------

   function "<" (Left, Right : SLOC_Link) return Boolean is
   begin
      return Left.Node < Right.Node;
   end "<";

   ---------
   -- "=" --
   ---------

   function "=" (Left, Right : SLOC_Link) return Boolean is
   begin
      return Left.Node = Right.Node;
   end "=";

   -------------------------------------
   -- Add_SLOC_Node_List_To_Node_List --
   -------------------------------------

   procedure Add_SLOC_Node_List_To_Node_List
     (Target : in out Node_Lists.Set;
      Source :        SLOC_Node_Lists.Set)
   is
      Next_Element : SLOC_Node_Lists.Cursor;
      Tmp_Cursor   : Node_Lists.Cursor;
      Tmp_Boolean  : Boolean;
      pragma Warnings (Off, Tmp_Cursor);
      pragma Warnings (Off, Tmp_Boolean);
   begin

      if not SLOC_Node_Lists.Is_Empty (Source) then

         Next_Element := SLOC_Node_Lists.First (Source);

         while SLOC_Node_Lists.Has_Element (Next_Element) loop

            Node_Lists.Insert
             (Container => Target,
              New_Item  => SLOC_Node_Lists.Element (Next_Element).Node,
              Position  => Tmp_Cursor,
              Inserted  => Tmp_Boolean);

            Next_Element := SLOC_Node_Lists.Next (Next_Element);
         end loop;

      end if;

   end Add_SLOC_Node_List_To_Node_List;

   -----------------------------
   -- Collect_Component_Calls --
   -----------------------------

   procedure Collect_Component_Calls
     (Element :        Asis.Element;
      Control : in out Traverse_Control;
      State   : in out No_State)
   is
      pragma Unreferenced (State);
      Tmp : Asis.Element;
   begin

      case Flat_Element_Kind (Element) is
         when A_Component_Declaration =>

            Tmp := Initialization_Expression (Element);

            if Is_Nil (Tmp) then
               --  But the compoenent type may have initialization procedures!
               Tmp := Object_Declaration_View (Element);
               Tmp := Component_Definition_View (Tmp);

               if Definition_Kind (Tmp) = A_Subtype_Indication then
                  Tmp := Get_Subtype_Structure (Tmp);

                  if Has_Type_Init_Proc (Tmp) then
                     Add_Link_To_SLOC_List
                       (To_Node     => Current_Scope,
                        To_List     => Calls,
                        Link_To_Add =>
                          (Node => Corresponding_Node
                                     (El            => Tmp,
                                      Expected_Kind => A_Type_Init_Procedure),
                           SLOC => Build_GNAT_Location (Element)));

                  end if;

               end if;
            else
               Unconditionally_Collect_CG_Info_From_Construct (Tmp);
            end if;

         when A_Protected_Definition                |
              A_Derived_Record_Extension_Definition |
              A_Record_Type_Definition              |
              A_Tagged_Record_Type_Definition       |
              A_Record_Definition                   |
              A_Variant_Part                        |
              A_Variant                             =>
            null;
         when others =>
            Control := Abandon_Children;
      end case;

   end Collect_Component_Calls;

   ------------------------------
   -- Collect_Discr_Init_Calls --
   ------------------------------

   procedure Collect_Discr_Init_Calls
     (Type_Decl      : Asis.Element;
      Init_Proc_Node : GS_Node_Id)
   is
      Parent_Type : Asis.Element;
   begin
      Set_Current_Scope (Init_Proc_Node, Node (Type_Decl));

      Parent_Type := Discriminant_Part (Type_Decl);

      if Is_Nil (Parent_Type) then
         --  Derived type that inherits discriminants from parent
         Parent_Type := Type_Declaration_View (Type_Decl);
         Parent_Type := Corresponding_Parent_Subtype (Parent_Type);

         if Declaration_Kind (Parent_Type) = A_Subtype_Declaration then
            Parent_Type := Corresponding_First_Subtype (Parent_Type);
         end if;

         --  Here we add to Init_Proc_Node the call to the discriminant
         --  initialization procedure of the parent type

         Add_Link_To_SLOC_List
           (To_Node     => Init_Proc_Node,
            To_List     => Calls,
            Link_To_Add =>
              (Node => Corresponding_Node
                         (El            => Parent_Type,
                          Expected_Kind => A_Type_Discr_Init_Procedure),
               SLOC => Build_GNAT_Location (Type_Decl)));

      else
         declare
            Discrs : constant Asis.Element_List := Discriminants (Parent_Type);
         begin

            for J in Discrs'Range loop
               Unconditionally_Collect_CG_Info_From_Construct
                 (Initialization_Expression (Discrs (J)));
            end loop;

         end;
      end if;

      Set_Body_Analyzed (Init_Proc_Node);

      Remove_Current_Scope;
   end Collect_Discr_Init_Calls;

   -----------------------------
   -- Collect_Type_Init_Calls --
   -----------------------------

   procedure Collect_Type_Init_Calls
     (Type_Decl      : Asis.Element;
      Init_Proc_Node : GS_Node_Id)
   is
      Type_Def    : Asis.Element;
      Parent_Type : Asis.Element;

      Control     : Traverse_Control := Continue;
      Tmp_State   : No_State := Not_Used;
   begin
      Set_Current_Scope (Init_Proc_Node, Node (Type_Decl));

      Type_Def := Type_Declaration_View (Type_Decl);

      case Flat_Element_Kind (Type_Def) is
         when A_Derived_Type_Definition         |
              An_Unconstrained_Array_Definition |
              A_Constrained_Array_Definition    =>

         --  The only possibility is that the parent/component type has an
            --  initialization procedure
            if Type_Kind (Type_Def) = A_Derived_Type_Definition then
               Parent_Type := Parent_Subtype_Indication (Type_Def);
            else
               Parent_Type := Array_Component_Definition (Type_Def);
               Parent_Type := Component_Definition_View  (Parent_Type);
            end if;

            Parent_Type := Get_Subtype_Structure (Parent_Type);

            Add_Link_To_SLOC_List
              (To_Node     => Init_Proc_Node,
               To_List     => Calls,
               Link_To_Add =>
                 (Node => Corresponding_Node
                            (El            => Parent_Type,
                             Expected_Kind => A_Type_Init_Procedure),
                  SLOC => Build_GNAT_Location (Type_Decl)));

         when A_Protected_Definition                |
              A_Derived_Record_Extension_Definition |
              A_Record_Type_Definition              |
              A_Tagged_Record_Type_Definition      =>

            Collect_Calls_From_Components (Type_Def, Control, Tmp_State);

            if Type_Kind (Type_Def) =
                A_Derived_Record_Extension_Definition
            then
               Parent_Type := Parent_Subtype_Indication (Type_Def);
               Parent_Type := Get_Subtype_Structure (Parent_Type);

               if Has_Type_Init_Proc (Parent_Type) then
                  Add_Link_To_SLOC_List
                     (To_Node     => Init_Proc_Node,
                      To_List     => Calls,
                      Link_To_Add =>
                        (Node => Corresponding_Node
                                   (El            => Parent_Type,
                                    Expected_Kind => A_Type_Init_Procedure),
                         SLOC => Build_GNAT_Location (Type_Decl)));

               end if;

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

      Set_Body_Analyzed (Init_Proc_Node);

      Remove_Current_Scope;
   end Collect_Type_Init_Calls;

   ------------------------
   -- Corresponding_Node --
   ------------------------

   function Corresponding_Node
     (El              : Element;
      Enclosing_Scope : Scope_Id      := No_Scope;
      Expected_Kind   : GS_Node_Kinds := Not_A_Node;
      Unconditionally : Boolean       := False)
      return            GS_Node_Id
   is
      Corresponding_El : constant Asis.Element := Corresponding_Element (El);

      Result : GS_Node_Id := Find_Node (Corresponding_El, Expected_Kind);
   begin

      if No (Result)
        and then
         (Unconditionally
         or else
          Expected_Kind in
            A_Type_Discr_Init_Procedure .. A_Type_Init_Procedure
         or else
          ASIS_UL.Global_State.CG.Conditions.Should_Be_In_CG
            (Corresponding_El))
      then
         Result :=
           Register_Node (Corresponding_El, Enclosing_Scope, Expected_Kind);
      end if;

      return Result;
   end Corresponding_Node;

   -------------------
   -- Current_Scope --
   -------------------

   function Current_Scope return Scope_Id is
   begin

      if Scope_Stack.Last >= Scope_Stack.First then
         return Scope_Stack.Table (Scope_Stack.Last).Scope;
      else
         raise Scope_Stack_Error;
      end if;

   end Current_Scope;

   -----------------------------
   -- Current_Scope_Tree_Node --
   -----------------------------

   function Current_Scope_Tree_Node return Node_Id is
   begin

      if Scope_Stack.Last >= Scope_Stack.First then
         return Scope_Stack.Table (Scope_Stack.Last).Scope_Tree_Node;
      else
         raise Scope_Stack_Error;
      end if;

   end Current_Scope_Tree_Node;

   -------------------------
   -- Define_GS_Node_Kind --
   -------------------------

   function Define_GS_Node_Kind (El : Asis.Element) return GS_Node_Kinds is
      Result : GS_Node_Kinds := Not_A_Node;
   begin

      case Flat_Element_Kind (El) is
         when A_Package_Declaration |
            A_Generic_Package_Declaration =>
            Result := A_Package;

         when A_Procedure_Declaration |
              A_Formal_Procedure_Declaration =>

            if Definition_Kind (Enclosing_Element (El)) =
                 A_Protected_Definition
            then
               Result := A_Protected_Procedure;
            else
               Result := A_Procedure;
            end if;

         when A_Procedure_Body_Declaration |
              A_Procedure_Body_Stub        |
              A_Procedure_Instantiation    =>
            Result := A_Procedure;

         when A_Null_Procedure_Declaration =>
            Result := A_Null_Procedure;

         when A_Function_Declaration |
              A_Formal_Function_Declaration =>

            if Definition_Kind (Enclosing_Element (El)) =
                 A_Protected_Definition
            then
               Result := A_Protected_Function;
            else
               Result := A_Function;
            end if;

         when A_Function_Body_Declaration        |
              An_Expression_Function_Declaration |
              A_Function_Body_Stub               |
              A_Function_Instantiation           =>
            Result := A_Function;

         when A_Task_Type_Declaration    |
               A_Single_Task_Declaration =>
            Result := A_Task;

         when An_Entry_Declaration =>

            if Definition_Kind (Enclosing_Element (El)) =
                 A_Protected_Definition
            then
               Result := A_Protected_Entry;
            else
               Result := A_Task_Entry;
            end if;

         when A_Defining_Identifier =>
            Result := A_Data_Object;
         when others =>
            null;
      end case;

      return Result;
   end Define_GS_Node_Kind;

   ---------------
   -- Find_Node --
   ---------------

   function Find_Node
     (El            : Asis.Element;
      Expected_Kind : GS_Node_Kinds := Not_A_Node)
      return          GS_Node_Id
   is
      Result : GS_Node_Id;
   begin

      Result := Hash_Table (Hash (El));

      while Present (Result) loop

         if Is_Equal (Result, El, Expected_Kind) then
            exit;
         end if;

         Result := Table (Result).Hash_Link;
      end loop;

      return Result;
   end Find_Node;

   -------------------
   -- Get_Node_Name --
   -------------------

   function Get_Node_Name
     (El        : Asis.Element;
      Node_Kind : GS_Node_Kinds)
      return      String
   is
      Result : constant String := To_String (Defining_Name_Image (El));
   begin
      pragma Assert (Node_Kind /= Not_A_Node);

      case Node_Kind is
         when A_Type_Discr_Init_Procedure =>
            return Result & "'Discr_Init";
         when A_Type_Init_Procedure =>
            return Result & "'Init";
         when others =>
            return Result;
      end case;
   end Get_Node_Name;

   ----------
   -- Hash --
   ----------

   function Hash (El : Asis.Element) return Hash_Index_Type is
   begin
      return Asis.Elements.Hash (El) mod Hash_Num;
   end Hash;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      GS_Nodes_Container.Reserve_Capacity
        (Container => GS_Nodes_Table,
         Capacity  => 1_000);

      Scope_Stack.Init;
      Hash_Table   := (others => No_GS_Node);

      --  Locating the node representing the evironment task:
      GS_Nodes_Container.Append (Container => GS_Nodes_Table,
                                 New_Item  => Environment_Task_Node_Rec);

      Environment_Task_Node := Last_Node;

      Set_Current_Scope (Environment_Task_Node, Empty);
   end Initialize;

   ----------------------
   -- Is_Callable_Node --
   ----------------------

   function Is_Callable_Node (N : GS_Node_Id) return Boolean is
   begin
      pragma Assert (Present (N));
      return GS_Node_Kind (N) in Callable_Nodes;
   end Is_Callable_Node;

   --------------
   -- Is_Equal --
   --------------

   function Is_Equal
     (N             : GS_Node_Id;
      El            : Asis.Element;
      Expected_Kind : GS_Node_Kinds := Not_A_Node)
      return          Boolean
   is
      Required_Kins : GS_Node_Kinds := Expected_Kind;
      Result        : Boolean       := False;
      El_For_SLOC   : Asis.Element;
   begin

      pragma Assert (Is_Equal (El, Corresponding_Element (El)));

      if Required_Kins = Not_A_Node then
         Required_Kins := Define_GS_Node_Kind (El);
      end if;

      if Defining_Name_Kind (El) /= A_Defining_Identifier then
         --  Callable entity
         El_For_SLOC := Get_Defining_Name (El);
      else
         El_For_SLOC := El;
      end if;

      if Present (N)
        and then
         not Is_Nil (El)
      then
         if GS_Node_Kind (N) = Required_Kins
           and then
             Get_String (GS_Node_SLOC (N)) = Build_GNAT_Location (El_For_SLOC)
         then
            Result := True;
         end if;

      end if;

      return Result;
   end Is_Equal;

   ------------------------
   -- Is_Subprogram_Node --
   ------------------------

   function Is_Subprogram_Node (N : GS_Node_Id) return Boolean is
   begin
      pragma Assert (Present (N));
      return GS_Node_Kind (N) in Subprogram_Nodes
            or else
             GS_Node_Kind (N) in Protected_Subprogram_Nodes;
   end Is_Subprogram_Node;

   ---------------
   -- Last_Node --
   ---------------

   function Last_Node return GS_Node_Id is
   begin
      return GS_Nodes_Container.Last_Index (GS_Nodes_Table);
   end Last_Node;

   --------
   -- No --
   --------

   function No (N : GS_Node_Id) return Boolean is
   begin
      return N = No_GS_Node;
   end No;

   -------------
   -- Present --
   -------------

   function Present (N : GS_Node_Id) return Boolean is
   begin
      return N /= No_GS_Node;
   end Present;

   ----------------------------
   -- Print_Global_Structure --
   ----------------------------

   All_Calls_Count     : Natural := 0;
   Direct_Calls_Count  : Natural := 0;
   Direct_Reads_Count  : Natural := 0;
   Direct_Writes_Count : Natural := 0;

   procedure Print_Global_Structure is
   begin
      if Debug_Flag_G then
         All_Calls_Count     := 0;
         Direct_Calls_Count  := 0;
         Direct_Reads_Count  := 0;
         Direct_Writes_Count := 0;

         for J in First_GS_Node .. Last_Node loop
            Print_Node (J);
            Info ("");
         end loop;

         New_Line;
         New_Line;

         Info ("Direct_Calls :" & Direct_Calls_Count'Img);
         Info ("All_Calls    :" & All_Calls_Count'Img);

         if Global_Objects_Accessed then
            Info ("Direct_Reads :" & Direct_Reads_Count'Img);
            Info ("Direct_Writes:" & Direct_Writes_Count'Img);
         end if;
      end if;
   end Print_Global_Structure;

   ----------------
   -- Print_List --
   ----------------

   procedure Print_List (Node_List : Node_Lists.Set) is
      Next_El : Node_Lists.Cursor := Node_Lists.First (Node_List);

      use Node_Lists;
   begin

      if Next_El = Node_Lists.No_Element then
         Info_No_EOL (" ...nothing...");
      else

         while Next_El /= Node_Lists.No_Element loop
            Info_No_EOL (Node_Lists.Element (Next_El)'Img);
            Next_El := Node_Lists.Next (Next_El);
         end loop;

      end if;

      Info ("");

   end Print_List;

   ----------------
   -- Print_Node --
   ----------------

   procedure Print_Node (N : GS_Node_Id) is
   begin
      --  Common node fields:

      Info_No_EOL ("Node_Id =" & N'Img);
      Info (" (" & GS_Node_Name (N) & ")");

      Info_No_EOL (Ident_String);
      Info ("Node_Kind       = " &  GS_Node_Kind (N)'Img);

      Info_No_EOL (Ident_String);
      Info_No_EOL ("SLOC            = " & Get_String (GS_Node_SLOC (N)));
      Info (" (SF_Id =" & Enclosing_Source (N)'Img & ")");

      Info_No_EOL (Ident_String);
      Info ("Enclosing_Scope = " & GS_Node_Enclosing_Scope (N)'Img);

      Info_No_EOL (Ident_String);
      Info ("Scope level =" & GS_Node_Scope_Level (N)'Img);

      if Is_Of_No_Interest (N) then
         Info_No_EOL (Ident_String);
         Info ("This node is of no interest for global analysis");
      end if;

      --  Fields that meaning depend on node class:

      if GS_Node_Kind (N) in Callable_Nodes then
         Info_No_EOL (Ident_String);
         Info ("Body analyzed    = " & Body_Analyzed (N)'Img);

         if GS_Is_Renaming (N) then
            Info_No_EOL (Ident_String);
            Info ("This is a renaming node");
         end if;

         if GS_Is_Task_Type (N) then
            Info_No_EOL (Ident_String);
            Info ("This is a task type node");
         end if;

         if GS_Node_Kind (N) in Subprogram_Nodes
           and then
            Is_Dispatching_Operation_Node (N)
         then
            Info_No_EOL (Ident_String);
            Info ("This is a dispatching operation node");
         end if;

         if GS_Node_Kind (N) in Subprogram_Nodes then

            if Is_Abstract_Subprogram_Node (N) then
               Info_No_EOL (Ident_String);
               Info ("This is an abstract operation node");
            end if;

            if Is_Implicit_Subprogram_Node (N) then
               Info_No_EOL (Ident_String);
               Info ("This is an implicit subprogram node");
            end if;

         end if;

         Info_No_EOL (2 * Ident_String & "direct calls             :");
         Print_SLOC_List (Table (N).SLOC_Node_List_1);

         Info_No_EOL (2 * Ident_String & "postponed disp calls     :");
         Print_SLOC_List (Table (N).Dispatching_Calls);

         Direct_Calls_Count :=
           Direct_Calls_Count +
             Natural (SLOC_Node_Lists.Length (Table (N).SLOC_Node_List_1));

         Info_No_EOL (2 * Ident_String & "all calls                :");
         Print_List (Table (N).Node_List_1);

         Info_No_EOL (2 * Ident_String & "direct dispatching calls :");
         Print_List (Table (N).Node_List_2);

         if GS_Node_Kind (N) in Subprogram_Nodes
           and then
            Is_Dispatching_Operation_Node (N)
         then
            Info_No_EOL (2 * Ident_String & "directly dispatched to   :");
            Print_List (Table (N).Node_List_3);

            Info_No_EOL (2 * Ident_String & "may be dispatched to     :");
            Print_List (Table (N).Node_List_4);
         end if;

         All_Calls_Count :=
           All_Calls_Count +
             Natural (Node_Lists.Length (Table (N).Node_List_1));

         Info_No_EOL (2 * Ident_String & "direct reads             :");
         Print_SLOC_List (Table (N).SLOC_Node_List_2);

         Direct_Reads_Count :=
           Direct_Reads_Count +
             Natural (SLOC_Node_Lists.Length (Table (N).SLOC_Node_List_2));

         Info_No_EOL (2 * Ident_String & "direct writes            :");
         Print_SLOC_List (Table (N).SLOC_Node_List_3);

         Direct_Writes_Count :=
           Direct_Writes_Count +
             Natural (SLOC_Node_Lists.Length (Table (N).SLOC_Node_List_3));

         Info_No_EOL (2 * Ident_String & "indirect reads           :");
         Print_List (Table (N).Node_List_5);

         Info_No_EOL (2 * Ident_String & "indirect writes          :");
         Print_List (Table (N).Node_List_6);
      else
         null;
      end if;

      --  Application_Specific flags:

      Info_No_EOL (Ident_String);
      Info ("Application flag 1  = " & Get_Application_Flag_1 (N)'Img);

   end Print_Node;

   ---------------------
   -- Print_SLOC_List --
   ---------------------

   procedure Print_SLOC_List (Node_List : SLOC_Node_Lists.Set) is
      Next_El : SLOC_Node_Lists.Cursor := SLOC_Node_Lists.First (Node_List);

      use SLOC_Node_Lists;
   begin

      if Next_El = SLOC_Node_Lists.No_Element then
         Info_No_EOL (" ...nothing...");
      else

         Info ("");

         while Next_El /= SLOC_Node_Lists.No_Element loop
            Info_No_EOL (Ident_String);
            Info_No_EOL (Ident_String);
            Info_No_EOL (SLOC_Node_Lists.Element (Next_El).Node'Img);
            Info ("(" &
                  Get_String (SLOC_Node_Lists.Element (Next_El).SLOC) & ")");
            Next_El := SLOC_Node_Lists.Next (Next_El);
         end loop;

      end if;

      Info ("");

   end Print_SLOC_List;

   -------------------
   -- Register_Node --
   -------------------

   function Register_Node
     (El            : Asis.Element;
      Encl_Scope    : Scope_Id      := No_Scope;
      Expected_Kind : GS_Node_Kinds := Not_A_Node)
      return GS_Node_Id
   is
      Encl_Scope_Node  :          Scope_Id        := Encl_Scope;
      Tmp              :          Asis.Element;
      New_Node         :          GS_Node_Record;
      New_Node_Kind    :          GS_Node_Kinds   := Expected_Kind;
      Hash_Value       : constant Hash_Index_Type := Hash (El);
      Last_In_Chain    :          GS_Node_Id      := Hash_Table (Hash_Value);
      Node_Source_File :          SF_Id           := No_SF_Id;
      Is_RTL_Node      : constant Boolean         :=
        Unit_Origin (Enclosing_Compilation_Unit (El)) /= An_Application_Unit;
      El_For_SLOC      :          Asis.Element;
      Entity_Def_Name  :          Asis.Element;

      Result           : GS_Node_Id;
   begin

      if No (Encl_Scope_Node) then
         --  The following may cause creation of a whole bunch of nodes

         Tmp := Enclosing_Scope (El);

         if Is_Nil (Tmp) then
            Encl_Scope_Node := Environment_Task_Node;
         else
            Encl_Scope_Node :=
              Corresponding_Node (Corresponding_Element (Tmp));
         end if;
      end if;

      if not ASIS_UL.Options.Process_RTL_Units
       and then
         Is_RTL_Node
      then
         null;
         --  To be completed later. Node_Source_File remains null...
      else
         Node_Source_File := File_Find (El);
         --  To be completed later...

         if not Present (Node_Source_File) then
            Node_Source_File :=
               Add_Needed_Source
                 (Normalize_Pathname
                    (To_String
                       (Asis.Compilation_Units.Text_Name
                          (Asis.Elements.Enclosing_Compilation_Unit (El))),
                     Resolve_Links  => False,
                     Case_Sensitive => True));

         end if;

      end if;

      if New_Node_Kind = Not_A_Node then
         New_Node_Kind := Define_GS_Node_Kind (El);
      end if;

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

      New_Node :=
        (Node_Kind          => New_Node_Kind,
         SLOC               => Build_GNAT_Location (El_For_SLOC),
         Name               =>
           Enter_String (Get_Node_Name (Entity_Def_Name, New_Node_Kind)),
         Source_File        => Node_Source_File,
         Enclosing_Scope    => Encl_Scope_Node,
         Scope_Level        => 1,
         Hash_Link          => No_GS_Node,
         Is_RTL_Node        => Is_RTL_Node,
         Is_Of_No_Interest  => False,

         Bool_Flag_1        => False,
         Bool_Flag_2        => False,
         Bool_Flag_3        => False,
         Bool_Flag_4        => False,
         Bool_Flag_5        => False,
         Bool_Flag_6        => False,
         Application_Flag_1 => False,
         SLOC_Node_List_1   => SLOC_Node_Lists.Empty_Set,
         SLOC_Node_List_2   => SLOC_Node_Lists.Empty_Set,  --  Direct reads
         SLOC_Node_List_3   => SLOC_Node_Lists.Empty_Set,  --  Direct writes
         Dispatching_Calls  => SLOC_Node_Lists.Empty_Set,  -- Dispatching calls
         Node_List_1        => Node_Lists.Empty_Set,  --  All_Calls
         Node_List_2        => Node_Lists.Empty_Set, --  Direct disp calls
         Node_List_3        => Node_Lists.Empty_Set, --  Directly impl spbs
         Node_List_4        => Node_Lists.Empty_Set, --  All impl spbs
         Node_List_5        => Node_Lists.Empty_Set, --  Indirect reads
         Node_List_6        => Node_Lists.Empty_Set, --  Indirect writes
         Bool_Flag_7               => False          --  Missing_Body_Reported
         );

      pragma Assert (New_Node.Node_Kind /= Not_A_Node);

      if New_Node.Node_Kind in Subprogram_Nodes then
         New_Node.Bool_Flag_4 := Is_Dispatching_Operation (El);

         if Declaration_Kind (El) = An_Expression_Function_Declaration then
            New_Node.Bool_Flag_1 := True; --  Is_Body_Analyzed
         end if;

         if Trait_Kind (El) = An_Abstract_Trait then
            New_Node.Bool_Flag_1 := True; --  Is_Body_Analyzed
            New_Node.Bool_Flag_5 := True; --  Is_Abstract_Subprogram_Node
         end if;

         New_Node.Bool_Flag_6 := Is_Part_Of_Implicit (El);

         --  Temporary workaround for incomplete implementation of dispatching
         --  subprogram elimination. At the moment we cannot properly handle
         --  multiple inheritance case, so if a dispatching operation belongs
         --  to a type that inherits anything from some interface type, we
         --  mark it as used    ???

--         if New_Node.Bool_Flag_4
--           and then
--             Belongs_To_Multiple_Inheritance (El)
--         then
--            New_Node.Application_Flag_1 := True;
--         end if;

      end if;

      GS_Nodes_Container.Append
        (Container => GS_Nodes_Table,
         New_Item  => New_Node);

      Result := Last_Node;

      if No (Last_In_Chain) then
         Hash_Table (Hash_Value) := Result;
      else

         while Present (GS_Node_Hash_Link (Last_In_Chain)) loop
            Last_In_Chain := GS_Node_Hash_Link (Last_In_Chain);
         end loop;

         Set_Hash_Link
           (N   => Last_In_Chain,
            Val => Result);
      end if;

      --  Try to compute node properties...

      if New_Node.Node_Kind in Callable_Nodes then

         if Is_Imported_Subprogram (El)
           or else
            Is_Part_Of_Implicit (El)
           or else
            New_Node_Kind = A_Null_Procedure
         then
            Set_Body_Analyzed (Result);
         end if;

         if New_Node.Node_Kind /= A_Type_Discr_Init_Procedure
           and then
            Declaration_Kind (El) = A_Task_Type_Declaration
         then
            Set_Is_Task_Type (Result);
         end if;

         if Is_Exported (First_Name (El)) then
            --  Exported subprogram, is considered as being called by the
            --  environment task
            Add_Link_To_SLOC_List
              (To_Node     => Environment_Task_Node,
               Link_To_Add => (Result, New_Node.SLOC));
         end if;

         if Is_Controlling_Type_Operation (El) then
            --  Subprogram that is implicitly called when object of a
            --  controlled type is created, destroyed or assigned, is
            --  considered as being called by the scope where the subprogram
            --  is declared
            Add_Link_To_SLOC_List
              (To_Node     => Encl_Scope_Node,
               Link_To_Add => (Result, New_Node.SLOC));
         end if;

         if New_Node_Kind = A_Type_Discr_Init_Procedure then
            Collect_Discr_Init_Calls (El, Result);
         end if;

         if New_Node_Kind = A_Type_Init_Procedure then
            Collect_Type_Init_Calls (El, Result);
         end if;

         if ASIS_UL.Options.Represent_Dispatching_Calls
           and then
            Is_Dispatching_Operation_Node (Result)
           and then
            (Is_Overriding_Operation (El)
            or else
             Is_Part_Of_Inherited (El))
         then
            Set_Implementing_Node (Implemented_Operations (El), Result);
         end if;
      end if;

      return Result;

   end Register_Node;

   --------------------------
   -- Remove_Current_Scope --
   --------------------------

   procedure Remove_Current_Scope is
   begin

      if Scope_Stack.Last >= Scope_Stack.First then
         Scope_Stack.Decrement_Last;
      else
         raise Scope_Stack_Error;
      end if;

   end Remove_Current_Scope;

   -----------------------
   -- Set_Current_Scope --
   -----------------------

   procedure Set_Current_Scope
     (Scope           : GS_Node_Id;
      Scope_Tree_Node : Node_Id)
   is
   begin
      Scope_Stack.Append ((Scope, Scope_Tree_Node));

      Set_Scope_Level
        (N   => Scope,
         Val => Scope_Stack.Last);
   end Set_Current_Scope;

   -----------
   -- Table --
   -----------

   function Table (N : GS_Node_Id) return GS_Node_Record_Access is
      Result : GS_Node_Record_Access;

      procedure Process (E : in out GS_Node_Record);

      procedure Process (E : in out GS_Node_Record) is
      begin
         Result := E'Unrestricted_Access;
      end Process;
   begin

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Process'Access);

      return Result;

   end Table;

   ----------------------------
   -- Common node attributes --
   ----------------------------

   function All_Calls (N : GS_Node_Id) return Node_List_Access is
   begin
      pragma Assert (Present (N) and then Is_Callable_Node (N));
      return Table (N).Node_List_1'Unrestricted_Access;
   end All_Calls;

   function Direct_Calls (N : GS_Node_Id) return SLOC_Node_List_Access is
   begin
      pragma Assert (Present (N) and then Is_Callable_Node (N));
      return Table (N).SLOC_Node_List_1'Unrestricted_Access;
   end Direct_Calls;

   function Direct_Reads (N : GS_Node_Id) return SLOC_Node_List_Access is
   begin
      pragma Assert (Present (N) and then Is_Callable_Node (N));
      return Table (N).SLOC_Node_List_2'Unrestricted_Access;
   end Direct_Reads;

   function Direct_Writes (N : GS_Node_Id) return SLOC_Node_List_Access is
   begin
      pragma Assert (Present (N) and then Is_Callable_Node (N));
      return Table (N).SLOC_Node_List_3'Unrestricted_Access;
   end Direct_Writes;

   function Indirect_Reads (N : GS_Node_Id) return Node_List_Access is
   begin
      pragma Assert (Present (N) and then Is_Callable_Node (N));
      return Table (N).Node_List_5'Unrestricted_Access;
   end Indirect_Reads;

   function Indirect_Writes (N : GS_Node_Id) return Node_List_Access is
   begin
      pragma Assert (Present (N) and then Is_Callable_Node (N));
      return Table (N).Node_List_6'Unrestricted_Access;
   end Indirect_Writes;

   function Enclosing_Source (N : GS_Node_Id) return SF_Id is
   begin
      return Table (N).Source_File;
   end Enclosing_Source;

   function  Get_Application_Flag_1 (N : GS_Node_Id) return Boolean is
   begin
      pragma Assert (Present (N));
      return Table (N).Application_Flag_1;
   end Get_Application_Flag_1;

   function GS_Enclosed_CU_Name (N : GS_Node_Id) return String is
   begin
      pragma Assert (Present (N) and then N /= Environment_Task_Node);

      return CU_Name (Enclosing_Source (N));

   end GS_Enclosed_CU_Name;

   function GS_Node_Enclosing_Scope (N : GS_Node_Id) return Scope_Id is
   begin

      if No (N) then
         return No_Scope;
      else
         return Table (N).Enclosing_Scope;
      end if;

   end GS_Node_Enclosing_Scope;

   function GS_Node_Hash_Link (N : GS_Node_Id) return GS_Node_Id is
   begin

      if No (N) then
         return No_GS_Node;
      else
         return Table (N).Hash_Link;
      end if;

   end GS_Node_Hash_Link;

   function GS_Node_Kind (N : GS_Node_Id) return GS_Node_Kinds is
   begin
      if No (N) then
         return Not_A_Node;
      else
         return Table (N).Node_Kind;
      end if;
   end GS_Node_Kind;

   function GS_Node_Name (N : GS_Node_Id) return String is
   begin
      pragma Assert (Present (N));
      return Get_String (Table (N).Name);
   end GS_Node_Name;

   function GS_Node_Scope_Level (N : GS_Node_Id) return Natural is
   begin
      return Table (N).Scope_Level;
   end GS_Node_Scope_Level;

   function GS_Node_SLOC (N : GS_Node_Id) return String_Loc is
   begin
      if No (N) then
         return Nil_String_Loc;
      else
         return Table (N).SLOC;
      end if;
   end GS_Node_SLOC;

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

      if GS_Node_Kind (N) in Subprogram_Nodes then
         return Table (N).Bool_Flag_5;
      else
         return False;
      end if;

   end Is_Abstract_Subprogram_Node;

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

      if GS_Node_Kind (N) in Subprogram_Nodes then
         return Table (N).Bool_Flag_6;
      else
         return False;
      end if;

   end Is_Implicit_Subprogram_Node;

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

      if GS_Node_Kind (N) in Subprogram_Nodes then
         return Table (N).Bool_Flag_4;
      else
         return False;
      end if;

   end Is_Dispatching_Operation_Node;

   function Is_Of_No_Interest (N : GS_Node_Id) return Boolean is
   begin
      return Table (N).Is_Of_No_Interest
        or else
          (not ASIS_UL.Options.Process_RTL_Units
          and then
           Table (N).Is_RTL_Node);
   end Is_Of_No_Interest;

   function Is_RTL_Node (N : GS_Node_Id) return Boolean is
   begin
      return Table (N).Is_RTL_Node;
   end Is_RTL_Node;

   --------------------------------------
   -- Node attribute update procedures --
   --------------------------------------

   Bool_Tmp                : Boolean;
   SLOC_Link_List_Type_Tmp : SLOC_Link_List_Types;
   SLOC_Link_Tmp           : SLOC_Link;
   GS_Node_Tmp             : GS_Node_Id;
   Int_Tmp                 : Integer;
   --  Data to keep the value to be assigned to the record node field

   procedure Add_Link_To_SLOC_List  (For_Node_Rec : in out GS_Node_Record);
   procedure Set_Hash_Link          (For_Node_Rec : in out GS_Node_Record);
   procedure Set_Is_Of_No_Interest  (For_Node_Rec : in out GS_Node_Record);
   procedure Set_Scope_Level        (For_Node_Rec : in out GS_Node_Record);

   procedure Set_Bool_Flag_1        (For_Node_Rec : in out GS_Node_Record);
   procedure Set_Bool_Flag_2        (For_Node_Rec : in out GS_Node_Record);
   procedure Set_Bool_Flag_3        (For_Node_Rec : in out GS_Node_Record);
   procedure Set_Bool_Flag_4        (For_Node_Rec : in out GS_Node_Record);
   procedure Set_Bool_Flag_5        (For_Node_Rec : in out GS_Node_Record);
   procedure Set_Bool_Flag_6        (For_Node_Rec : in out GS_Node_Record);
   procedure Set_Bool_Flag_7        (For_Node_Rec : in out GS_Node_Record);
   procedure Set_Application_Flag_1 (For_Node_Rec : in out GS_Node_Record);
   --  Procedures for updating the node record fields.

   ------------------------------------------------------------------------

   procedure Add_Link_To_SLOC_List (For_Node_Rec : in out GS_Node_Record) is
      Tmp_SLOC_Cursor : SLOC_Node_Lists.Cursor;
      Tmp_Cursor      : Node_Lists.Cursor;
      Tmp_Boolean     : Boolean;
      pragma Warnings (Off, Tmp_SLOC_Cursor);
      pragma Warnings (Off, Tmp_Cursor);
      pragma Warnings (Off, Tmp_Boolean);
   begin

      case SLOC_Link_List_Type_Tmp is
         when Calls =>
            SLOC_Node_Lists.Insert
             (Container => For_Node_Rec.SLOC_Node_List_1,
              New_Item  => SLOC_Link_Tmp,
              Position  => Tmp_SLOC_Cursor,
              Inserted  => Tmp_Boolean);
         when Dispatching_Calls =>
            SLOC_Node_Lists.Insert
             (Container => For_Node_Rec.Dispatching_Calls,
              New_Item  => SLOC_Link_Tmp,
              Position  => Tmp_SLOC_Cursor,
              Inserted  => Tmp_Boolean);
--         when All_Calls =>
--            Node_Lists.Insert
--             (Container => For_Node_Rec.All_Calls_Chain,
--              New_Item  => Link_Tmp,
--              Position  => Tmp_Cursor,
--              Inserted  => Tmp_Boolean);
         when Direct_Read_References =>
            SLOC_Node_Lists.Insert
              (Container => For_Node_Rec.SLOC_Node_List_2,
               New_Item  => SLOC_Link_Tmp,
               Position  => Tmp_SLOC_Cursor,
               Inserted  => Tmp_Boolean);
         when Direct_Write_References =>
            SLOC_Node_Lists.Insert
              (Container => For_Node_Rec.SLOC_Node_List_3,
               New_Item  => SLOC_Link_Tmp,
               Position  => Tmp_SLOC_Cursor,
               Inserted  => Tmp_Boolean);
         when Indirect_Read_References =>
            Node_Lists.Insert
              (Container => For_Node_Rec.Node_List_5,
               New_Item  => SLOC_Link_Tmp.Node,
               Position  => Tmp_Cursor,
               Inserted  => Tmp_Boolean);
         when Indirect_Write_References =>
            Node_Lists.Insert
              (Container => For_Node_Rec.Node_List_6,
               New_Item  => SLOC_Link_Tmp.Node,
               Position  => Tmp_Cursor,
               Inserted  => Tmp_Boolean);
      end case;

   end Add_Link_To_SLOC_List;

   procedure Set_Bool_Flag_1 (For_Node_Rec : in out GS_Node_Record) is
   begin
      For_Node_Rec.Bool_Flag_1 := Bool_Tmp;
   end Set_Bool_Flag_1;

   procedure Set_Bool_Flag_2 (For_Node_Rec : in out GS_Node_Record) is
   begin
      For_Node_Rec.Bool_Flag_2 := Bool_Tmp;
   end Set_Bool_Flag_2;

   procedure Set_Bool_Flag_3 (For_Node_Rec : in out GS_Node_Record) is
   begin
      For_Node_Rec.Bool_Flag_3 := Bool_Tmp;
   end Set_Bool_Flag_3;

   procedure Set_Bool_Flag_4 (For_Node_Rec : in out GS_Node_Record) is
   begin
      For_Node_Rec.Bool_Flag_4 := Bool_Tmp;
   end Set_Bool_Flag_4;

   procedure Set_Bool_Flag_5 (For_Node_Rec : in out GS_Node_Record) is
   begin
      For_Node_Rec.Bool_Flag_5 := Bool_Tmp;
   end Set_Bool_Flag_5;

   procedure Set_Bool_Flag_6 (For_Node_Rec : in out GS_Node_Record) is
   begin
      For_Node_Rec.Bool_Flag_6 := Bool_Tmp;
   end Set_Bool_Flag_6;

   procedure Set_Bool_Flag_7 (For_Node_Rec : in out GS_Node_Record) is
   begin
      For_Node_Rec.Bool_Flag_7 := Bool_Tmp;
   end Set_Bool_Flag_7;

   procedure Set_Application_Flag_1 (For_Node_Rec : in out GS_Node_Record) is
   begin
      For_Node_Rec.Application_Flag_1 := Bool_Tmp;
   end Set_Application_Flag_1;

   procedure Set_Hash_Link (For_Node_Rec : in out GS_Node_Record) is
   begin
      For_Node_Rec.Hash_Link := GS_Node_Tmp;
   end Set_Hash_Link;

   procedure Set_Is_Of_No_Interest (For_Node_Rec : in out GS_Node_Record) is
   begin
      For_Node_Rec.Is_Of_No_Interest := Bool_Tmp;
   end Set_Is_Of_No_Interest;

   procedure Set_Scope_Level (For_Node_Rec : in out GS_Node_Record) is
   begin
      For_Node_Rec.Scope_Level := Int_Tmp;
   end Set_Scope_Level;

   ------------------------------------------------------------------------

   procedure Add_Link_To_SLOC_List
     (To_Node     : GS_Node_Id;
      Link_To_Add : SLOC_Link;
      To_List     : SLOC_Link_List_Types := Calls)
   is
   begin

      SLOC_Link_Tmp           := Link_To_Add;
      SLOC_Link_List_Type_Tmp := To_List;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => To_Node,
         Process   => Add_Link_To_SLOC_List'Access);
   end Add_Link_To_SLOC_List;

   procedure Set_Bool_Flag_1 (N : GS_Node_Id; Val : Boolean) is
   begin
      Bool_Tmp := Val;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Set_Bool_Flag_1'Access);
   end Set_Bool_Flag_1;

   procedure Set_Bool_Flag_2 (N : GS_Node_Id; Val : Boolean) is
   begin
      Bool_Tmp := Val;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Set_Bool_Flag_2'Access);
   end Set_Bool_Flag_2;

   procedure Set_Bool_Flag_3 (N : GS_Node_Id; Val : Boolean) is
   begin
      Bool_Tmp := Val;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Set_Bool_Flag_3'Access);
   end Set_Bool_Flag_3;

   procedure Set_Bool_Flag_4 (N : GS_Node_Id; Val : Boolean) is
   begin
      Bool_Tmp := Val;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Set_Bool_Flag_4'Access);
   end Set_Bool_Flag_4;

   procedure Set_Bool_Flag_5 (N : GS_Node_Id; Val : Boolean) is
   begin
      Bool_Tmp := Val;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Set_Bool_Flag_5'Access);
   end Set_Bool_Flag_5;

   procedure Set_Bool_Flag_6 (N : GS_Node_Id; Val : Boolean) is
   begin
      Bool_Tmp := Val;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Set_Bool_Flag_6'Access);
   end Set_Bool_Flag_6;

   procedure Set_Bool_Flag_7 (N : GS_Node_Id; Val : Boolean) is
   begin
      Bool_Tmp := Val;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Set_Bool_Flag_7'Access);
   end Set_Bool_Flag_7;

   procedure Set_Application_Flag_1 (N : GS_Node_Id; Val : Boolean) is
   begin
      Bool_Tmp := Val;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Set_Application_Flag_1'Access);
   end Set_Application_Flag_1;

   procedure Set_Hash_Link
     (N             : GS_Node_Id;
      Val           : GS_Node_Id)
   is
   begin
      GS_Node_Tmp := Val;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Set_Hash_Link'Access);
   end Set_Hash_Link;

   procedure Set_Is_Of_No_Interest (N : GS_Node_Id; Val : Boolean := True) is
   begin
      Bool_Tmp := Val;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Set_Is_Of_No_Interest'Access);
   end Set_Is_Of_No_Interest;

   procedure Set_Scope_Level (N : GS_Node_Id; Val : Positive) is
   begin
      Int_Tmp := Val;

      GS_Nodes_Container.Update_Element
        (Container => GS_Nodes_Table,
         Index     => N,
         Process   => Set_Scope_Level'Access);

   end Set_Scope_Level;

begin

   Environment_Task_Node_Rec :=
     (Node_Kind                 => Environment_Task,
      SLOC                      => Nil_String_Loc,
      Name                      => Enter_String ("__Environment_Task"),
      Enclosing_Scope           => No_Scope,
      Scope_Level               => 0,
      Source_File               => No_SF_Id,
      Hash_Link                 => No_GS_Node,
      Is_RTL_Node               => False,
      Is_Of_No_Interest         => False,
      Bool_Flag_1               => True,           --  Is_Body_Analyzed
      Bool_Flag_2               => False,          --  Is_Renaming
      Bool_Flag_3               => False,          --  Is_Task_Type
      Bool_Flag_4               => False,          --  Is_Dispatching_Operation
      Bool_Flag_5               => False,          --  Is_Abstract_Subprogram
      Bool_Flag_6               => False,          --  Is_Implicit_Subprogram
      Bool_Flag_7               => False,          --  Missing_Body_Reported
      Application_Flag_1        => False,
      SLOC_Node_List_1          => SLOC_Node_Lists.Empty_Set, --  Direct_Calls
      SLOC_Node_List_2          => SLOC_Node_Lists.Empty_Set, --  Direct reads
      SLOC_Node_List_3          => SLOC_Node_Lists.Empty_Set, --  Direct writes
      Dispatching_Calls         => SLOC_Node_Lists.Empty_Set, -- Disp calls
      Node_List_1               => Node_Lists.Empty_Set,      --  All_Calls
      Node_List_2               => Node_Lists.Empty_Set, --  Direct disp calls
      Node_List_3               => Node_Lists.Empty_Set, --  Directly impl spbs
      Node_List_4               => Node_Lists.Empty_Set, --  All impl spbs
      Node_List_5               => Node_Lists.Empty_Set, --  Indirect reads
      Node_List_6               => Node_Lists.Empty_Set  --  Indirect writes
     );

end ASIS_UL.Global_State;