path: root/gcc/ada/libgnat/g-graphs.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                           G N A T . G R A P H S                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--             Copyright (C) 2018-2023, Free Software Foundation, Inc.      --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Deallocation;

package body GNAT.Graphs is

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

   function Sequence_Next_Component return Component_Id;
   --  Produce the next handle for a component. The handle is guaranteed to be
   --  unique across all graphs.

   --------------------
   -- Directed_Graph --
   --------------------

   package body Directed_Graphs is

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

      procedure Add_Component
        (G        : Directed_Graph;
         Comp     : Component_Id;
         Vertices : Vertex_List.Doubly_Linked_List);
      pragma Inline (Add_Component);
      --  Add component Comp which houses vertices Vertices to graph G

      procedure Ensure_Created (G : Directed_Graph);
      pragma Inline (Ensure_Created);
      --  Verify that graph G is created. Raise Not_Created if this is not the
      --  case.

      procedure Ensure_Not_Present
        (G : Directed_Graph;
         E : Edge_Id);
      pragma Inline (Ensure_Not_Present);
      --  Verify that graph G lacks edge E. Raise Duplicate_Edge if this is not
      --  the case.

      procedure Ensure_Not_Present
        (G : Directed_Graph;
         V : Vertex_Id);
      pragma Inline (Ensure_Not_Present);
      --  Verify that graph G lacks vertex V. Raise Duplicate_Vertex if this is
      --  not the case.

      procedure Ensure_Present
        (G    : Directed_Graph;
         Comp : Component_Id);
      pragma Inline (Ensure_Present);
      --  Verify that component Comp exists in graph G. Raise Missing_Component
      --  if this is not the case.

      procedure Ensure_Present
        (G : Directed_Graph;
         E : Edge_Id);
      pragma Inline (Ensure_Present);
      --  Verify that edge E is present in graph G. Raise Missing_Edge if this
      --  is not the case.

      procedure Ensure_Present
        (G : Directed_Graph;
         V : Vertex_Id);
      pragma Inline (Ensure_Present);
      --  Verify that vertex V is present in graph G. Raise Missing_Vertex if
      --  this is not the case.

      procedure Free is
        new Ada.Unchecked_Deallocation
              (Directed_Graph_Attributes, Directed_Graph);

      function Get_Component_Attributes
        (G    : Directed_Graph;
         Comp : Component_Id) return Component_Attributes;
      pragma Inline (Get_Component_Attributes);
      --  Obtain the attributes of component Comp of graph G

      function Get_Edge_Attributes
        (G : Directed_Graph;
         E : Edge_Id) return Edge_Attributes;
      pragma Inline (Get_Edge_Attributes);
      --  Obtain the attributes of edge E of graph G

      function Get_Vertex_Attributes
        (G : Directed_Graph;
         V : Vertex_Id) return Vertex_Attributes;
      pragma Inline (Get_Vertex_Attributes);
      --  Obtain the attributes of vertex V of graph G

      function Get_Outgoing_Edges
        (G : Directed_Graph;
         V : Vertex_Id) return Edge_Set.Membership_Set;
      pragma Inline (Get_Outgoing_Edges);
      --  Obtain the Outgoing_Edges attribute of vertex V of graph G

      function Get_Vertices
        (G    : Directed_Graph;
         Comp : Component_Id) return Vertex_List.Doubly_Linked_List;
      pragma Inline (Get_Vertices);
      --  Obtain the Vertices attribute of component Comp of graph G

      procedure Set_Component
        (G   : Directed_Graph;
         V   : Vertex_Id;
         Val : Component_Id);
      pragma Inline (Set_Component);
      --  Set attribute Component of vertex V of graph G to value Val

      procedure Set_Outgoing_Edges
        (G   : Directed_Graph;
         V   : Vertex_Id;
         Val : Edge_Set.Membership_Set);
      pragma Inline (Set_Outgoing_Edges);
      --  Set attribute Outgoing_Edges of vertex V of graph G to value Val

      procedure Set_Vertex_Attributes
        (G   : Directed_Graph;
         V   : Vertex_Id;
         Val : Vertex_Attributes);
      pragma Inline (Set_Vertex_Attributes);
      --  Set the attributes of vertex V of graph G to value Val

      -------------------
      -- Add_Component --
      -------------------

      procedure Add_Component
        (G        : Directed_Graph;
         Comp     : Component_Id;
         Vertices : Vertex_List.Doubly_Linked_List)
      is
      begin
         pragma Assert (Present (G));

         --  Add the component to the set of all components in the graph

         Component_Map.Put
           (T     => G.Components,
            Key   => Comp,
            Value => (Vertices => Vertices));
      end Add_Component;

      --------------
      -- Add_Edge --
      --------------

      procedure Add_Edge
        (G           : Directed_Graph;
         E           : Edge_Id;
         Source      : Vertex_Id;
         Destination : Vertex_Id)
      is
      begin
         Ensure_Created (G);
         Ensure_Not_Present (G, E);
         Ensure_Present (G, Source);
         Ensure_Present (G, Destination);

         --  Add the edge to the set of all edges in the graph

         Edge_Map.Put
           (T     => G.All_Edges,
            Key   => E,
            Value =>
              (Destination => Destination,
               Source      => Source));

         --  Associate the edge with its source vertex which effectively "owns"
         --  the edge.

         Edge_Set.Insert
           (S    => Get_Outgoing_Edges (G, Source),
            Elem => E);
      end Add_Edge;

      ----------------
      -- Add_Vertex --
      ----------------

      procedure Add_Vertex
        (G : Directed_Graph;
         V : Vertex_Id)
      is
      begin
         Ensure_Created (G);
         Ensure_Not_Present (G, V);

         --  Add the vertex to the set of all vertices in the graph

         Vertex_Map.Put
           (T     => G.All_Vertices,
            Key   => V,
            Value =>
              (Component      => No_Component,
               Outgoing_Edges => Edge_Set.Nil));

         --  It is assumed that the vertex will have at least one outgoing
         --  edge. It is important not to create the set of edges above as
         --  the call to Put may fail in case the vertices are iterated.
         --  This would lead to a memory leak because the set would not be
         --  reclaimed.

         Set_Outgoing_Edges (G, V, Edge_Set.Create (1));
      end Add_Vertex;

      ---------------
      -- Component --
      ---------------

      function Component
        (G : Directed_Graph;
         V : Vertex_Id) return Component_Id
      is
      begin
         Ensure_Created (G);
         Ensure_Present (G, V);

         return Get_Vertex_Attributes (G, V).Component;
      end Component;

      ------------------------
      -- Contains_Component --
      ------------------------

      function Contains_Component
        (G    : Directed_Graph;
         Comp : Component_Id) return Boolean
      is
      begin
         Ensure_Created (G);

         return Component_Map.Contains (G.Components, Comp);
      end Contains_Component;

      -------------------
      -- Contains_Edge --
      -------------------

      function Contains_Edge
        (G : Directed_Graph;
         E : Edge_Id) return Boolean
      is
      begin
         Ensure_Created (G);

         return Edge_Map.Contains (G.All_Edges, E);
      end Contains_Edge;

      ---------------------
      -- Contains_Vertex --
      ---------------------

      function Contains_Vertex
        (G : Directed_Graph;
         V : Vertex_Id) return Boolean
      is
      begin
         Ensure_Created (G);

         return Vertex_Map.Contains (G.All_Vertices, V);
      end Contains_Vertex;

      ------------
      -- Create --
      ------------

      function Create
        (Initial_Vertices : Positive;
         Initial_Edges    : Positive) return Directed_Graph
      is
         G : constant Directed_Graph := new Directed_Graph_Attributes;

      begin
         G.All_Edges    := Edge_Map.Create      (Initial_Edges);
         G.All_Vertices := Vertex_Map.Create    (Initial_Vertices);
         G.Components   := Component_Map.Create (Initial_Vertices);

         return G;
      end Create;

      -----------------
      -- Delete_Edge --
      -----------------

      procedure Delete_Edge
        (G : Directed_Graph;
         E : Edge_Id)
      is
         Source : Vertex_Id;

      begin
         Ensure_Created (G);
         Ensure_Present (G, E);

         Source := Source_Vertex (G, E);
         Ensure_Present (G, Source);

         --  Delete the edge from its source vertex which effectively "owns"
         --  the edge.

         Edge_Set.Delete (Get_Outgoing_Edges (G, Source), E);

         --  Delete the edge from the set of all edges

         Edge_Map.Delete (G.All_Edges, E);
      end Delete_Edge;

      ------------------------
      -- Destination_Vertex --
      ------------------------

      function Destination_Vertex
        (G : Directed_Graph;
         E : Edge_Id) return Vertex_Id
      is
      begin
         Ensure_Created (G);
         Ensure_Present (G, E);

         return Get_Edge_Attributes (G, E).Destination;
      end Destination_Vertex;

      -------------
      -- Destroy --
      -------------

      procedure Destroy (G : in out Directed_Graph) is
      begin
         Ensure_Created (G);

         Edge_Map.Destroy      (G.All_Edges);
         Vertex_Map.Destroy    (G.All_Vertices);
         Component_Map.Destroy (G.Components);

         Free (G);
      end Destroy;

      ----------------------------------
      -- Destroy_Component_Attributes --
      ----------------------------------

      procedure Destroy_Component_Attributes
        (Attrs : in out Component_Attributes)
      is
      begin
         Vertex_List.Destroy (Attrs.Vertices);
      end Destroy_Component_Attributes;

      -----------------------------
      -- Destroy_Edge_Attributes --
      -----------------------------

      procedure Destroy_Edge_Attributes (Attrs : in out Edge_Attributes) is
         pragma Unreferenced (Attrs);
      begin
         null;
      end Destroy_Edge_Attributes;

      --------------------
      -- Destroy_Vertex --
      --------------------

      procedure Destroy_Vertex (V : in out Vertex_Id) is
         pragma Unreferenced (V);
      begin
         null;
      end Destroy_Vertex;

      -------------------------------
      -- Destroy_Vertex_Attributes --
      -------------------------------

      procedure Destroy_Vertex_Attributes (Attrs : in out Vertex_Attributes) is
      begin
         Edge_Set.Destroy (Attrs.Outgoing_Edges);
      end Destroy_Vertex_Attributes;

      --------------------
      -- Ensure_Created --
      --------------------

      procedure Ensure_Created (G : Directed_Graph) is
      begin
         if not Present (G) then
            raise Not_Created;
         end if;
      end Ensure_Created;

      ------------------------
      -- Ensure_Not_Present --
      ------------------------

      procedure Ensure_Not_Present
        (G : Directed_Graph;
         E : Edge_Id)
      is
      begin
         if Contains_Edge (G, E) then
            raise Duplicate_Edge;
         end if;
      end Ensure_Not_Present;

      ------------------------
      -- Ensure_Not_Present --
      ------------------------

      procedure Ensure_Not_Present
        (G : Directed_Graph;
         V : Vertex_Id)
      is
      begin
         if Contains_Vertex (G, V) then
            raise Duplicate_Vertex;
         end if;
      end Ensure_Not_Present;

      --------------------
      -- Ensure_Present --
      --------------------

      procedure Ensure_Present
        (G    : Directed_Graph;
         Comp : Component_Id)
      is
      begin
         if not Contains_Component (G, Comp) then
            raise Missing_Component;
         end if;
      end Ensure_Present;

      --------------------
      -- Ensure_Present --
      --------------------

      procedure Ensure_Present
        (G : Directed_Graph;
         E : Edge_Id)
      is
      begin
         if not Contains_Edge (G, E) then
            raise Missing_Edge;
         end if;
      end Ensure_Present;

      --------------------
      -- Ensure_Present --
      --------------------

      procedure Ensure_Present
        (G : Directed_Graph;
         V : Vertex_Id)
      is
      begin
         if not Contains_Vertex (G, V) then
            raise Missing_Vertex;
         end if;
      end Ensure_Present;

      ---------------------
      -- Find_Components --
      ---------------------

      procedure Find_Components (G : Directed_Graph) is

         --  The components of graph G are discovered using Tarjan's strongly
         --  connected component algorithm. Do not modify this code unless you
         --  intimately understand the algorithm.

         ----------------
         -- Tarjan_Map --
         ----------------

         type Visitation_Number is new Natural;
         No_Visitation_Number    : constant Visitation_Number :=
                                      Visitation_Number'First;
         First_Visitation_Number : constant Visitation_Number :=
                                     No_Visitation_Number + 1;

         type Tarjan_Attributes is record
            Index : Visitation_Number := No_Visitation_Number;
            --  Visitation number

            Low_Link : Visitation_Number := No_Visitation_Number;
            --  Lowest visitation number

            On_Stack : Boolean := False;
            --  Set when the corresponding vertex appears on the Stack
         end record;

         No_Tarjan_Attributes : constant Tarjan_Attributes :=
           (Index    => No_Visitation_Number,
            Low_Link => No_Visitation_Number,
            On_Stack => False);

         procedure Destroy_Tarjan_Attributes
           (Attrs : in out Tarjan_Attributes);
         --  Destroy the contents of attributes Attrs

         package Tarjan_Map is new Dynamic_Hash_Tables
           (Key_Type              => Vertex_Id,
            Value_Type            => Tarjan_Attributes,
            No_Value              => No_Tarjan_Attributes,
            Expansion_Threshold   => 1.5,
            Expansion_Factor      => 2,
            Compression_Threshold => 0.3,
            Compression_Factor    => 2,
            "="                   => Same_Vertex,
            Destroy_Value         => Destroy_Tarjan_Attributes,
            Hash                  => Hash_Vertex);

         ------------------
         -- Tarjan_Stack --
         ------------------

         package Tarjan_Stack is new Doubly_Linked_Lists
           (Element_Type    => Vertex_Id,
            "="             => Same_Vertex,
            Destroy_Element => Destroy_Vertex);

         -----------------
         -- Global data --
         -----------------

         Attrs : Tarjan_Map.Dynamic_Hash_Table   := Tarjan_Map.Nil;
         Stack : Tarjan_Stack.Doubly_Linked_List := Tarjan_Stack.Nil;

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

         procedure Associate_All_Vertices;
         pragma Inline (Associate_All_Vertices);
         --  Associate all vertices in the graph with the corresponding
         --  components that house them.

         procedure Associate_Vertices (Comp : Component_Id);
         pragma Inline (Associate_Vertices);
         --  Associate all vertices of component Comp with the component

         procedure Create_Component (V : Vertex_Id);
         pragma Inline (Create_Component);
         --  Create a new component with root vertex V

         function Get_Tarjan_Attributes
           (V : Vertex_Id) return Tarjan_Attributes;
         pragma Inline (Get_Tarjan_Attributes);
         --  Obtain the Tarjan attributes of vertex V

         function Index (V : Vertex_Id) return Visitation_Number;
         pragma Inline (Index);
         --  Obtain the Index attribute of vertex V

         procedure Initialize_Components;
         pragma Inline (Initialize_Components);
         --  Initialize or reinitialize the components of the graph

         function Is_Visited (V : Vertex_Id) return Boolean;
         pragma Inline (Is_Visited);
         --  Determine whether vertex V has been visited

         function Low_Link (V : Vertex_Id) return Visitation_Number;
         pragma Inline (Low_Link);
         --  Obtain the Low_Link attribute of vertex V

         function On_Stack (V : Vertex_Id) return Boolean;
         pragma Inline (On_Stack);
         --  Obtain the On_Stack attribute of vertex V

         function Pop return Vertex_Id;
         pragma Inline (Pop);
         --  Pop a vertex off Stack

         procedure Push (V : Vertex_Id);
         pragma Inline (Push);
         --  Push vertex V on Stack

         procedure Record_Visit (V : Vertex_Id);
         pragma Inline (Record_Visit);
         --  Save the visitation of vertex V by setting relevant attributes

         function Sequence_Next_Index return Visitation_Number;
         pragma Inline (Sequence_Next_Index);
         --  Procedure the next visitation number of the DFS traversal

         procedure Set_Index
           (V   : Vertex_Id;
            Val : Visitation_Number);
         pragma Inline (Set_Index);
         --  Set attribute Index of vertex V to value Val

         procedure Set_Low_Link
           (V   : Vertex_Id;
            Val : Visitation_Number);
         pragma Inline (Set_Low_Link);
         --  Set attribute Low_Link of vertex V to value Val

         procedure Set_On_Stack
           (V   : Vertex_Id;
            Val : Boolean);
         pragma Inline (Set_On_Stack);
         --  Set attribute On_Stack of vertex V to value Val

         procedure Set_Tarjan_Attributes
           (V   : Vertex_Id;
            Val : Tarjan_Attributes);
         pragma Inline (Set_Tarjan_Attributes);
         --  Set the attributes of vertex V to value Val

         procedure Visit_Successors (V : Vertex_Id);
         pragma Inline (Visit_Successors);
         --  Visit the successors of vertex V

         procedure Visit_Vertex (V : Vertex_Id);
         pragma Inline (Visit_Vertex);
         --  Visit single vertex V

         procedure Visit_Vertices;
         pragma Inline (Visit_Vertices);
         --  Visit all vertices in the graph

         ----------------------------
         -- Associate_All_Vertices --
         ----------------------------

         procedure Associate_All_Vertices is
            Comp : Component_Id;
            Iter : Component_Iterator;

         begin
            Iter := Iterate_Components (G);
            while Has_Next (Iter) loop
               Next (Iter, Comp);

               Associate_Vertices (Comp);
            end loop;
         end Associate_All_Vertices;

         ------------------------
         -- Associate_Vertices --
         ------------------------

         procedure Associate_Vertices (Comp : Component_Id) is
            Iter : Component_Vertex_Iterator;
            V    : Vertex_Id;

         begin
            Iter := Iterate_Component_Vertices (G, Comp);
            while Has_Next (Iter) loop
               Next (Iter, V);

               Set_Component (G, V, Comp);
            end loop;
         end Associate_Vertices;

         ----------------------
         -- Create_Component --
         ----------------------

         procedure Create_Component (V : Vertex_Id) is
            Curr_V   : Vertex_Id;
            Vertices : Vertex_List.Doubly_Linked_List;

         begin
            Vertices := Vertex_List.Create;

            --  Collect all vertices that comprise the current component by
            --  popping the stack until reaching the root vertex V.

            loop
               Curr_V := Pop;
               Vertex_List.Append (Vertices, Curr_V);

               exit when Same_Vertex (Curr_V, V);
            end loop;

            Add_Component
              (G        => G,
               Comp     => Sequence_Next_Component,
               Vertices => Vertices);
         end Create_Component;

         -------------------------------
         -- Destroy_Tarjan_Attributes --
         -------------------------------

         procedure Destroy_Tarjan_Attributes
           (Attrs : in out Tarjan_Attributes)
         is
            pragma Unreferenced (Attrs);
         begin
            null;
         end Destroy_Tarjan_Attributes;

         ---------------------------
         -- Get_Tarjan_Attributes --
         ---------------------------

         function Get_Tarjan_Attributes
           (V : Vertex_Id) return Tarjan_Attributes
         is
         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            return Tarjan_Map.Get (Attrs, V);
         end Get_Tarjan_Attributes;

         -----------
         -- Index --
         -----------

         function Index (V : Vertex_Id) return Visitation_Number is
         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            return Get_Tarjan_Attributes (V).Index;
         end Index;

         ---------------------------
         -- Initialize_Components --
         ---------------------------

         procedure Initialize_Components is
         begin
            pragma Assert (Present (G));

            --  The graph already contains a set of components. Reinitialize
            --  them in order to accommodate the new set of components about to
            --  be computed.

            if Number_Of_Components (G) > 0 then
               Component_Map.Destroy (G.Components);
               G.Components := Component_Map.Create (Number_Of_Vertices (G));
            end if;
         end Initialize_Components;

         ----------------
         -- Is_Visited --
         ----------------

         function Is_Visited (V : Vertex_Id) return Boolean is
         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            return Index (V) /= No_Visitation_Number;
         end Is_Visited;

         --------------
         -- Low_Link --
         --------------

         function Low_Link (V : Vertex_Id) return Visitation_Number is
         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            return Get_Tarjan_Attributes (V).Low_Link;
         end Low_Link;

         --------------
         -- On_Stack --
         --------------

         function On_Stack (V : Vertex_Id) return Boolean is
         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            return Get_Tarjan_Attributes (V).On_Stack;
         end On_Stack;

         ---------
         -- Pop --
         ---------

         function Pop return Vertex_Id is
            V : Vertex_Id;

         begin
            V := Tarjan_Stack.Last (Stack);
            Tarjan_Stack.Delete_Last (Stack);
            Set_On_Stack (V, False);

            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            return V;
         end Pop;

         ----------
         -- Push --
         ----------

         procedure Push (V : Vertex_Id) is
         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            Tarjan_Stack.Append (Stack, V);
            Set_On_Stack (V, True);
         end Push;

         ------------------
         -- Record_Visit --
         ------------------

         procedure Record_Visit (V : Vertex_Id) is
            Index : constant Visitation_Number := Sequence_Next_Index;

         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            Set_Index    (V, Index);
            Set_Low_Link (V, Index);
         end Record_Visit;

         -------------------------
         -- Sequence_Next_Index --
         -------------------------

         Index_Sequencer : Visitation_Number := First_Visitation_Number;
         --  The counter for visitation numbers. Do not directly manipulate its
         --  value because this will destroy the Index and Low_Link invariants
         --  of the algorithm.

         function Sequence_Next_Index return Visitation_Number is
            Index : constant Visitation_Number := Index_Sequencer;

         begin
            Index_Sequencer := Index_Sequencer + 1;
            return Index;
         end Sequence_Next_Index;

         ---------------
         -- Set_Index --
         ---------------

         procedure Set_Index
           (V   : Vertex_Id;
            Val : Visitation_Number)
         is
            TA : Tarjan_Attributes;

         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            TA := Get_Tarjan_Attributes (V);
            TA.Index := Val;
            Set_Tarjan_Attributes (V, TA);
         end Set_Index;

         ------------------
         -- Set_Low_Link --
         ------------------

         procedure Set_Low_Link
           (V   : Vertex_Id;
            Val : Visitation_Number)
         is
            TA : Tarjan_Attributes;

         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            TA := Get_Tarjan_Attributes (V);
            TA.Low_Link := Val;
            Set_Tarjan_Attributes (V, TA);
         end Set_Low_Link;

         ------------------
         -- Set_On_Stack --
         ------------------

         procedure Set_On_Stack
           (V   : Vertex_Id;
            Val : Boolean)
         is
            TA : Tarjan_Attributes;

         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            TA := Get_Tarjan_Attributes (V);
            TA.On_Stack := Val;
            Set_Tarjan_Attributes (V, TA);
         end Set_On_Stack;

         ---------------------------
         -- Set_Tarjan_Attributes --
         ---------------------------

         procedure Set_Tarjan_Attributes
           (V   : Vertex_Id;
            Val : Tarjan_Attributes)
         is
         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            Tarjan_Map.Put (Attrs, V, Val);
         end Set_Tarjan_Attributes;

         ----------------------
         -- Visit_Successors --
         ----------------------

         procedure Visit_Successors (V : Vertex_Id) is
            E    : Edge_Id;
            Iter : Outgoing_Edge_Iterator;
            Succ : Vertex_Id;

         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            Iter := Iterate_Outgoing_Edges (G, V);
            while Has_Next (Iter) loop
               Next (Iter, E);

               Succ := Destination_Vertex (G, E);
               pragma Assert (Contains_Vertex (G, Succ));

               --  The current successor has not been visited yet. Extend the
               --  DFS traversal into it.

               if not Is_Visited (Succ) then
                  Visit_Vertex (Succ);

                  Set_Low_Link (V,
                    Visitation_Number'Min (Low_Link (V), Low_Link (Succ)));

               --  The current successor has been visited, and still remains on
               --  the stack which indicates that it does not participate in a
               --  component yet.

               elsif On_Stack (Succ) then
                  Set_Low_Link (V,
                    Visitation_Number'Min (Low_Link (V), Index (Succ)));
               end if;
            end loop;
         end Visit_Successors;

         ------------------
         -- Visit_Vertex --
         ------------------

         procedure Visit_Vertex (V : Vertex_Id) is
         begin
            pragma Assert (Present (G));
            pragma Assert (Contains_Vertex (G, V));

            if not Is_Visited (V) then
               Record_Visit     (V);
               Push             (V);
               Visit_Successors (V);

               --  The current vertex is the root of a component

               if Low_Link (V) = Index (V) then
                  Create_Component (V);
               end if;
            end if;
         end Visit_Vertex;

         --------------------
         -- Visit_Vertices --
         --------------------

         procedure Visit_Vertices is
            Iter : All_Vertex_Iterator;
            V    : Vertex_Id;

         begin
            Iter := Iterate_All_Vertices (G);
            while Has_Next (Iter) loop
               Next (Iter, V);

               Visit_Vertex (V);
            end loop;
         end Visit_Vertices;

      --  Start of processing for Find_Components

      begin
         --  Initialize or reinitialize the components of the graph

         Initialize_Components;

         --  Prepare the extra attributes needed for each vertex, global
         --  visitation number, and the stack where examined vertices are
         --  placed.

         Attrs := Tarjan_Map.Create (Number_Of_Vertices (G));
         Stack := Tarjan_Stack.Create;

         --  Start the DFS traversal of Tarjan's SCC algorithm

         Visit_Vertices;

         Tarjan_Map.Destroy   (Attrs);
         Tarjan_Stack.Destroy (Stack);

         --  Associate each vertex with the component it belongs to

         Associate_All_Vertices;
      end Find_Components;

      ------------------------------
      -- Get_Component_Attributes --
      ------------------------------

      function Get_Component_Attributes
        (G    : Directed_Graph;
         Comp : Component_Id) return Component_Attributes
      is
      begin
         pragma Assert (Present (G));
         pragma Assert (Contains_Component (G, Comp));

         return Component_Map.Get (G.Components, Comp);
      end Get_Component_Attributes;

      -------------------------
      -- Get_Edge_Attributes --
      -------------------------

      function Get_Edge_Attributes
        (G : Directed_Graph;
         E : Edge_Id) return Edge_Attributes
      is
      begin
         pragma Assert (Present (G));
         pragma Assert (Contains_Edge (G, E));

         return Edge_Map.Get (G.All_Edges, E);
      end Get_Edge_Attributes;

      ---------------------------
      -- Get_Vertex_Attributes --
      ---------------------------

      function Get_Vertex_Attributes
        (G : Directed_Graph;
         V : Vertex_Id) return Vertex_Attributes
      is
      begin
         pragma Assert (Present (G));
         pragma Assert (Contains_Vertex (G, V));

         return Vertex_Map.Get (G.All_Vertices, V);
      end Get_Vertex_Attributes;

      ------------------------
      -- Get_Outgoing_Edges --
      ------------------------

      function Get_Outgoing_Edges
        (G : Directed_Graph;
         V : Vertex_Id) return Edge_Set.Membership_Set
      is
      begin
         pragma Assert (Present (G));
         pragma Assert (Contains_Vertex (G, V));

         return Get_Vertex_Attributes (G, V).Outgoing_Edges;
      end Get_Outgoing_Edges;

      ------------------
      -- Get_Vertices --
      ------------------

      function Get_Vertices
        (G    : Directed_Graph;
         Comp : Component_Id) return Vertex_List.Doubly_Linked_List
      is
      begin
         pragma Assert (Present (G));
         pragma Assert (Contains_Component (G, Comp));

         return Get_Component_Attributes (G, Comp).Vertices;
      end Get_Vertices;

      --------------
      -- Has_Next --
      --------------

      function Has_Next (Iter : All_Edge_Iterator) return Boolean is
      begin
         return Edge_Map.Has_Next (Edge_Map.Iterator (Iter));
      end Has_Next;

      --------------
      -- Has_Next --
      --------------

      function Has_Next (Iter : All_Vertex_Iterator) return Boolean is
      begin
         return Vertex_Map.Has_Next (Vertex_Map.Iterator (Iter));
      end Has_Next;

      --------------
      -- Has_Next --
      --------------

      function Has_Next (Iter : Component_Iterator) return Boolean is
      begin
         return Component_Map.Has_Next (Component_Map.Iterator (Iter));
      end Has_Next;

      --------------
      -- Has_Next --
      --------------

      function Has_Next (Iter : Component_Vertex_Iterator) return Boolean is
      begin
         return Vertex_List.Has_Next (Vertex_List.Iterator (Iter));
      end Has_Next;

      --------------
      -- Has_Next --
      --------------

      function Has_Next (Iter : Outgoing_Edge_Iterator) return Boolean is
      begin
         return Edge_Set.Has_Next (Edge_Set.Iterator (Iter));
      end Has_Next;

      --------------
      -- Is_Empty --
      --------------

      function Is_Empty (G : Directed_Graph) return Boolean is
      begin
         Ensure_Created (G);

         return
           Edge_Map.Is_Empty (G.All_Edges)
             and then Vertex_Map.Is_Empty (G.All_Vertices);
      end Is_Empty;

      -----------------------
      -- Iterate_All_Edges --
      -----------------------

      function Iterate_All_Edges
        (G : Directed_Graph) return All_Edge_Iterator
      is
      begin
         Ensure_Created (G);

         return All_Edge_Iterator (Edge_Map.Iterate (G.All_Edges));
      end Iterate_All_Edges;

      --------------------------
      -- Iterate_All_Vertices --
      --------------------------

      function Iterate_All_Vertices
        (G : Directed_Graph) return All_Vertex_Iterator
      is
      begin
         Ensure_Created (G);

         return All_Vertex_Iterator (Vertex_Map.Iterate (G.All_Vertices));
      end Iterate_All_Vertices;

      ------------------------
      -- Iterate_Components --
      ------------------------

      function Iterate_Components
        (G : Directed_Graph) return Component_Iterator
      is
      begin
         Ensure_Created (G);

         return Component_Iterator (Component_Map.Iterate (G.Components));
      end Iterate_Components;

      --------------------------------
      -- Iterate_Component_Vertices --
      --------------------------------

      function Iterate_Component_Vertices
        (G    : Directed_Graph;
         Comp : Component_Id) return Component_Vertex_Iterator
      is
      begin
         Ensure_Created (G);
         Ensure_Present (G, Comp);

         return
           Component_Vertex_Iterator
             (Vertex_List.Iterate (Get_Vertices (G, Comp)));
      end Iterate_Component_Vertices;

      ----------------------------
      -- Iterate_Outgoing_Edges --
      ----------------------------

      function Iterate_Outgoing_Edges
        (G : Directed_Graph;
         V : Vertex_Id) return Outgoing_Edge_Iterator
      is
      begin
         Ensure_Created (G);
         Ensure_Present (G, V);

         return
           Outgoing_Edge_Iterator
             (Edge_Set.Iterate (Get_Outgoing_Edges (G, V)));
      end Iterate_Outgoing_Edges;

      ----------
      -- Next --
      ----------

      procedure Next
        (Iter : in out All_Edge_Iterator;
         E    : out Edge_Id)
      is
      begin
         Edge_Map.Next (Edge_Map.Iterator (Iter), E);
      end Next;

      ----------
      -- Next --
      ----------

      procedure Next
        (Iter : in out All_Vertex_Iterator;
         V    : out Vertex_Id)
      is
      begin
         Vertex_Map.Next (Vertex_Map.Iterator (Iter), V);
      end Next;

      ----------
      -- Next --
      ----------

      procedure Next
        (Iter : in out Component_Iterator;
         Comp : out Component_Id)
      is
      begin
         Component_Map.Next (Component_Map.Iterator (Iter), Comp);
      end Next;

      ----------
      -- Next --
      ----------

      procedure Next
        (Iter : in out Component_Vertex_Iterator;
         V    : out Vertex_Id)
      is
      begin
         Vertex_List.Next (Vertex_List.Iterator (Iter), V);
      end Next;

      ----------
      -- Next --
      ----------

      procedure Next
        (Iter : in out Outgoing_Edge_Iterator;
         E    : out Edge_Id)
      is
      begin
         Edge_Set.Next (Edge_Set.Iterator (Iter), E);
      end Next;

      ----------------------------------
      -- Number_Of_Component_Vertices --
      ----------------------------------

      function Number_Of_Component_Vertices
        (G    : Directed_Graph;
         Comp : Component_Id) return Natural
      is
      begin
         Ensure_Created (G);
         Ensure_Present (G, Comp);

         return Vertex_List.Size (Get_Vertices (G, Comp));
      end Number_Of_Component_Vertices;

      --------------------------
      -- Number_Of_Components --
      --------------------------

      function Number_Of_Components (G : Directed_Graph) return Natural is
      begin
         Ensure_Created (G);

         return Component_Map.Size (G.Components);
      end Number_Of_Components;

      ---------------------
      -- Number_Of_Edges --
      ---------------------

      function Number_Of_Edges (G : Directed_Graph) return Natural is
      begin
         Ensure_Created (G);

         return Edge_Map.Size (G.All_Edges);
      end Number_Of_Edges;

      ------------------------------
      -- Number_Of_Outgoing_Edges --
      ------------------------------

      function Number_Of_Outgoing_Edges
        (G : Directed_Graph;
         V : Vertex_Id) return Natural
      is
      begin
         Ensure_Created (G);
         Ensure_Present (G, V);

         return Edge_Set.Size (Get_Outgoing_Edges (G, V));
      end Number_Of_Outgoing_Edges;

      ------------------------
      -- Number_Of_Vertices --
      ------------------------

      function Number_Of_Vertices (G : Directed_Graph) return Natural is
      begin
         Ensure_Created (G);

         return Vertex_Map.Size (G.All_Vertices);
      end Number_Of_Vertices;

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

      function Present (G : Directed_Graph) return Boolean is
      begin
         return G /= Nil;
      end Present;

      -------------------
      -- Set_Component --
      -------------------

      procedure Set_Component
        (G   : Directed_Graph;
         V   : Vertex_Id;
         Val : Component_Id)
      is
         VA : Vertex_Attributes;

      begin
         pragma Assert (Present (G));
         pragma Assert (Contains_Vertex (G, V));

         VA := Get_Vertex_Attributes (G, V);
         VA.Component := Val;
         Set_Vertex_Attributes (G, V, VA);
      end Set_Component;

      ------------------------
      -- Set_Outgoing_Edges --
      ------------------------

      procedure Set_Outgoing_Edges
        (G   : Directed_Graph;
         V   : Vertex_Id;
         Val : Edge_Set.Membership_Set)
      is
         VA : Vertex_Attributes;

      begin
         pragma Assert (Present (G));
         pragma Assert (Contains_Vertex (G, V));

         VA := Get_Vertex_Attributes (G, V);
         VA.Outgoing_Edges := Val;
         Set_Vertex_Attributes (G, V, VA);
      end Set_Outgoing_Edges;

      ---------------------------
      -- Set_Vertex_Attributes --
      ---------------------------

      procedure Set_Vertex_Attributes
        (G   : Directed_Graph;
         V   : Vertex_Id;
         Val : Vertex_Attributes)
      is
      begin
         pragma Assert (Present (G));
         pragma Assert (Contains_Vertex (G, V));

         Vertex_Map.Put (G.All_Vertices, V, Val);
      end Set_Vertex_Attributes;

      -------------------
      -- Source_Vertex --
      -------------------

      function Source_Vertex
        (G : Directed_Graph;
         E : Edge_Id) return Vertex_Id
      is
      begin
         Ensure_Created (G);
         Ensure_Present (G, E);

         return Get_Edge_Attributes (G, E).Source;
      end Source_Vertex;
   end Directed_Graphs;

   --------------------
   -- Hash_Component --
   --------------------

   function Hash_Component (Comp : Component_Id) return Bucket_Range_Type is
   begin
      return Bucket_Range_Type (Comp);
   end Hash_Component;

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

   function Present (Comp : Component_Id) return Boolean is
   begin
      return Comp /= No_Component;
   end Present;

   -----------------------------
   -- Sequence_Next_Component --
   -----------------------------

   Component_Sequencer : Component_Id := First_Component;
   --  The counter for component handles. Do not directly manipulate its value
   --  because this will destroy the invariant of the handles.

   function Sequence_Next_Component return Component_Id is
      Component : constant Component_Id := Component_Sequencer;

   begin
      Component_Sequencer := Component_Sequencer + 1;
      return Component;
   end Sequence_Next_Component;

end GNAT.Graphs;