This patch introduces new unit GNAT.Graphs which currently provides a
directed graph abstraction.
------------
-- Source --
------------
-- operations.adb
with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT;
with GNAT.Graphs; use GNAT.Graphs;
with GNAT.Sets; use GNAT.Sets;
procedure Operations is
type Vertex_Id is
(No_V, VA, VB, VC, VD, VE, VF, VG, VH, VX, VY, VZ);
No_Vertex_Id : constant Vertex_Id := No_V;
function Hash_Vertex (V : Vertex_Id) return Bucket_Range_Type;
type Edge_Id is
(No_E, E1, E2, E3, E4, E5, E6, E7, E8, E9, E10, E97, E98, E99);
No_Edge_Id : constant Edge_Id := No_E;
function Hash_Edge (E : Edge_Id) return Bucket_Range_Type;
package ES is new Membership_Set
(Element_Type => Edge_Id,
"=" => "=",
Hash => Hash_Edge);
package DG is new Directed_Graph
(Vertex_Id => Vertex_Id,
No_Vertex => No_Vertex_Id,
Hash_Vertex => Hash_Vertex,
Same_Vertex => "=",
Edge_Id => Edge_Id,
No_Edge => No_Edge_Id,
Hash_Edge => Hash_Edge,
Same_Edge => "=");
use DG;
package VS is new Membership_Set
(Element_Type => Vertex_Id,
"=" => "=",
Hash => Hash_Vertex);
-----------------------
-- Local subprograms --
-----------------------
procedure Check_Belongs_To_Component
(R : String;
G : Instance;
V : Vertex_Id;
Exp_Comp : Component_Id);
-- Verify that vertex V of graph G belongs to component Exp_Comp. R is the
-- calling routine.
procedure Check_Belongs_To_Some_Component
(R : String;
G : Instance;
V : Vertex_Id);
-- Verify that vertex V of graph G belongs to some component. R is the
-- calling routine.
procedure Check_Destination_Vertex
(R : String;
G : Instance;
E : Edge_Id;
Exp_V : Vertex_Id);
-- Vertify that the destination vertex of edge E of grah G is Exp_V. R is
-- the calling routine.
procedure Check_Distinct_Components
(R : String;
Comp_1 : Component_Id;
Comp_2 : Component_Id);
-- Verify that components Comp_1 and Comp_2 are distinct (not the same)
procedure Check_Has_Component
(R : String;
G : Instance;
G_Name : String;
Comp : Component_Id);
-- Verify that graph G with name G_Name contains component Comp. R is the
-- calling routine.
procedure Check_Has_Edge
(R : String;
G : Instance;
E : Edge_Id);
-- Verify that graph G contains edge E. R is the calling routine.
procedure Check_Has_Vertex
(R : String;
G : Instance;
V : Vertex_Id);
-- Verify that graph G contains vertex V. R is the calling routine.
procedure Check_No_Component
(R : String;
G : Instance;
V : Vertex_Id);
-- Verify that vertex V does not belong to some component. R is the calling
-- routine.
procedure Check_No_Component
(R : String;
G : Instance;
G_Name : String;
Comp : Component_Id);
-- Verify that graph G with name G_Name does not contain component Comp. R
-- is the calling routine.
procedure Check_No_Edge
(R : String;
G : Instance;
E : Edge_Id);
-- Verify that graph G does not contain edge E. R is the calling routine.
procedure Check_No_Vertex
(R : String;
G : Instance;
V : Vertex_Id);
-- Verify that graph G does not contain vertex V. R is the calling routine.
procedure Check_Number_Of_Components
(R : String;
G : Instance;
Exp_Num : Natural);
-- Verify that graph G has exactly Exp_Num components. R is the calling
-- routine.
procedure Check_Number_Of_Edges
(R : String;
G : Instance;
Exp_Num : Natural);
-- Verify that graph G has exactly Exp_Num edges. R is the calling routine.
procedure Check_Number_Of_Vertices
(R : String;
G : Instance;
Exp_Num : Natural);
-- Verify that graph G has exactly Exp_Num vertices. R is the calling
-- routine.
procedure Check_Outgoing_Edge_Iterator
(R : String;
G : Instance;
V : Vertex_Id;
Set : ES.Instance);
-- Verify that all outgoing edges of vertex V of graph G can be iterated
-- and appear in set Set. R is the calling routine.
procedure Check_Source_Vertex
(R : String;
G : Instance;
E : Edge_Id;
Exp_V : Vertex_Id);
-- Vertify that the source vertex of edge E of grah G is Exp_V. R is the
-- calling routine.
procedure Check_Vertex_Iterator
(R : String;
G : Instance;
Comp : Component_Id;
Set : VS.Instance);
-- Verify that all vertices of component Comp of graph G can be iterated
-- and appear in set Set. R is the calling routine.
function Create_And_Populate return Instance;
-- Create a brand new graph (see body for the shape of the graph)
procedure Error (R : String; Msg : String);
-- Output an error message with text Msg within the context of routine R
procedure Test_Add_Edge;
-- Verify the semantics of routine Add_Edge
procedure Test_Add_Vertex;
-- Verify the semantics of routine Add_Vertex
procedure Test_All_Edge_Iterator;
-- Verify the semantics of All_Edge_Iterator
procedure Test_All_Vertex_Iterator;
-- Verify the semantics of All_Vertex_Iterator
procedure Test_Component;
-- Verify the semantics of routine Component
procedure Test_Component_Iterator;
-- Verify the semantics of Component_Iterator
procedure Test_Contains_Component;
-- Verify the semantics of routine Contains_Component
procedure Test_Contains_Edge;
-- Verify the semantics of routine Contains_Edge
procedure Test_Contains_Vertex;
-- Verify the semantics of routine Contains_Vertex
procedure Test_Delete_Edge;
-- Verify the semantics of routine Delete_Edge
procedure Test_Destination_Vertex;
-- Verify the semantics of routine Destination_Vertex
procedure Test_Find_Components;
-- Verify the semantics of routine Find_Components
procedure Test_Is_Empty;
-- Verify the semantics of routine Is_Empty
procedure Test_Number_Of_Components;
-- Verify the semantics of routine Number_Of_Components
procedure Test_Number_Of_Edges;
-- Verify the semantics of routine Number_Of_Edges
procedure Test_Number_Of_Vertices;
-- Verify the semantics of routine Number_Of_Vertices
procedure Test_Outgoing_Edge_Iterator;
-- Verify the semantics of Outgoing_Edge_Iterator
procedure Test_Present;
-- Verify the semantics of routine Present
procedure Test_Source_Vertex;
-- Verify the semantics of routine Source_Vertex
procedure Test_Vertex_Iterator;
-- Verify the semantics of Vertex_Iterator;
procedure Unexpected_Exception (R : String);
-- Output an error message concerning an unexpected exception within
-- routine R.
--------------------------------
-- Check_Belongs_To_Component --
--------------------------------
procedure Check_Belongs_To_Component
(R : String;
G : Instance;
V : Vertex_Id;
Exp_Comp : Component_Id)
is
Act_Comp : constant Component_Id := Component (G, V);
begin
if Act_Comp /= Exp_Comp then
Error (R, "inconsistent component for vertex " & V'Img);
Error (R, " expected: " & Exp_Comp'Img);
Error (R, " got : " & Act_Comp'Img);
end if;
end Check_Belongs_To_Component;
-------------------------------------
-- Check_Belongs_To_Some_Component --
-------------------------------------
procedure Check_Belongs_To_Some_Component
(R : String;
G : Instance;
V : Vertex_Id)
is
begin
if not Present (Component (G, V)) then
Error (R, "vertex " & V'Img & " does not belong to a component");
end if;
end Check_Belongs_To_Some_Component;
------------------------------
-- Check_Destination_Vertex --
------------------------------
procedure Check_Destination_Vertex
(R : String;
G : Instance;
E : Edge_Id;
Exp_V : Vertex_Id)
is
Act_V : constant Vertex_Id := Destination_Vertex (G, E);
begin
if Act_V /= Exp_V then
Error (R, "inconsistent destination vertex for edge " & E'Img);
Error (R, " expected: " & Exp_V'Img);
Error (R, " got : " & Act_V'Img);
end if;
end Check_Destination_Vertex;
-------------------------------
-- Check_Distinct_Components --
-------------------------------
procedure Check_Distinct_Components
(R : String;
Comp_1 : Component_Id;
Comp_2 : Component_Id)
is
begin
if Comp_1 = Comp_2 then
Error (R, "components are not distinct");
end if;
end Check_Distinct_Components;
-------------------------
-- Check_Has_Component --
-------------------------
procedure Check_Has_Component
(R : String;
G : Instance;
G_Name : String;
Comp : Component_Id)
is
begin
if not Contains_Component (G, Comp) then
Error (R, "graph " & G_Name & " lacks component");
end if;
end Check_Has_Component;
--------------------
-- Check_Has_Edge --
--------------------
procedure Check_Has_Edge
(R : String;
G : Instance;
E : Edge_Id)
is
begin
if not Contains_Edge (G, E) then
Error (R, "graph lacks edge " & E'Img);
end if;
end Check_Has_Edge;
----------------------
-- Check_Has_Vertex --
----------------------
procedure Check_Has_Vertex
(R : String;
G : Instance;
V : Vertex_Id)
is
begin
if not Contains_Vertex (G, V) then
Error (R, "graph lacks vertex " & V'Img);
end if;
end Check_Has_Vertex;
------------------------
-- Check_No_Component --
------------------------
procedure Check_No_Component
(R : String;
G : Instance;
V : Vertex_Id)
is
begin
if Present (Component (G, V)) then
Error (R, "vertex " & V'Img & " belongs to a component");
end if;
end Check_No_Component;
procedure Check_No_Component
(R : String;
G : Instance;
G_Name : String;
Comp : Component_Id)
is
begin
if Contains_Component (G, Comp) then
Error (R, "graph " & G_Name & " contains component");
end if;
end Check_No_Component;
-------------------
-- Check_No_Edge --
-------------------
procedure Check_No_Edge
(R : String;
G : Instance;
E : Edge_Id)
is
begin
if Contains_Edge (G, E) then
Error (R, "graph contains edge " & E'Img);
end if;
end Check_No_Edge;
---------------------
-- Check_No_Vertex --
---------------------
procedure Check_No_Vertex
(R : String;
G : Instance;
V : Vertex_Id)
is
begin
if Contains_Vertex (G, V) then
Error (R, "graph contains vertex " & V'Img);
end if;
end Check_No_Vertex;
--------------------------------
-- Check_Number_Of_Components --
--------------------------------
procedure Check_Number_Of_Components
(R : String;
G : Instance;
Exp_Num : Natural)
is
Act_Num : constant Natural := Number_Of_Components (G);
begin
if Act_Num /= Exp_Num then
Error (R, "inconsistent number of components");
Error (R, " expected: " & Exp_Num'Img);
Error (R, " got : " & Act_Num'Img);
end if;
end Check_Number_Of_Components;
---------------------------
-- Check_Number_Of_Edges --
---------------------------
procedure Check_Number_Of_Edges
(R : String;
G : Instance;
Exp_Num : Natural)
is
Act_Num : constant Natural := Number_Of_Edges (G);
begin
if Act_Num /= Exp_Num then
Error (R, "inconsistent number of edges");
Error (R, " expected: " & Exp_Num'Img);
Error (R, " got : " & Act_Num'Img);
end if;
end Check_Number_Of_Edges;
------------------------------
-- Check_Number_Of_Vertices --
------------------------------
procedure Check_Number_Of_Vertices
(R : String;
G : Instance;
Exp_Num : Natural)
is
Act_Num : constant Natural := Number_Of_Vertices (G);
begin
if Act_Num /= Exp_Num then
Error (R, "inconsistent number of vertices");
Error (R, " expected: " & Exp_Num'Img);
Error (R, " got : " & Act_Num'Img);
end if;
end Check_Number_Of_Vertices;
----------------------------------
-- Check_Outgoing_Edge_Iterator --
----------------------------------
procedure Check_Outgoing_Edge_Iterator
(R : String;
G : Instance;
V : Vertex_Id;
Set : ES.Instance)
is
E : Edge_Id;
Out_E_Iter : Outgoing_Edge_Iterator;
begin
-- Iterate over all outgoing edges of vertex V while removing edges seen
-- from the set.
Out_E_Iter := Iterate_Outgoing_Edges (G, V);
while Has_Next (Out_E_Iter) loop
Next (Out_E_Iter, E);
if ES.Contains (Set, E) then
ES.Delete (Set, E);
else
Error (R, "outgoing edge " & E'Img & " is not iterated");
end if;
end loop;
-- At this point the set of edges should be empty
if not ES.Is_Empty (Set) then
Error (R, "not all outgoing edges were iterated");
end if;
end Check_Outgoing_Edge_Iterator;
-------------------------
-- Check_Source_Vertex --
-------------------------
procedure Check_Source_Vertex
(R : String;
G : Instance;
E : Edge_Id;
Exp_V : Vertex_Id)
is
Act_V : constant Vertex_Id := Source_Vertex (G, E);
begin
if Act_V /= Exp_V then
Error (R, "inconsistent source vertex");
Error (R, " expected: " & Exp_V'Img);
Error (R, " got : " & Act_V'Img);
end if;
end Check_Source_Vertex;
---------------------------
-- Check_Vertex_Iterator --
---------------------------
procedure Check_Vertex_Iterator
(R : String;
G : Instance;
Comp : Component_Id;
Set : VS.Instance)
is
V : Vertex_Id;
V_Iter : Vertex_Iterator;
begin
-- Iterate over all vertices of component Comp while removing vertices
-- seen from the set.
V_Iter := Iterate_Vertices (G, Comp);
while Has_Next (V_Iter) loop
Next (V_Iter, V);
if VS.Contains (Set, V) then
VS.Delete (Set, V);
else
Error (R, "vertex " & V'Img & " is not iterated");
end if;
end loop;
-- At this point the set of vertices should be empty
if not VS.Is_Empty (Set) then
Error (R, "not all vertices were iterated");
end if;
end Check_Vertex_Iterator;
-------------------------
-- Create_And_Populate --
-------------------------
function Create_And_Populate return Instance is
G : constant Instance :=
Create (Initial_Vertices => Vertex_Id'Size,
Initial_Edges => Edge_Id'Size);
begin
-- 9 8 1 2
-- G <------ F <------ A ------> B -------> C
-- | ^ | | ^ ^
-- +------------------+ | +-------------------+
-- 10 | | 3
-- 4 | 5 |
-- v |
-- H D ---------+
-- | ^
-- | |
-- 6 | | 7
-- | |
-- v |
-- E
--
-- Components:
--
-- [A, F, G]
-- [B]
-- [C]
-- [D, E]
-- [H]
Add_Vertex (G, VA);
Add_Vertex (G, VB);
Add_Vertex (G, VC);
Add_Vertex (G, VD);
Add_Vertex (G, VE);
Add_Vertex (G, VF);
Add_Vertex (G, VG);
Add_Vertex (G, VH);
Add_Edge (G, E1, Source => VA, Destination => VB);
Add_Edge (G, E2, Source => VB, Destination => VC);
Add_Edge (G, E3, Source => VA, Destination => VC);
Add_Edge (G, E4, Source => VA, Destination => VD);
Add_Edge (G, E5, Source => VD, Destination => VB);
Add_Edge (G, E6, Source => VD, Destination => VE);
Add_Edge (G, E7, Source => VE, Destination => VD);
Add_Edge (G, E8, Source => VA, Destination => VF);
Add_Edge (G, E9, Source => VF, Destination => VG);
Add_Edge (G, E10, Source => VG, Destination => VA);
return G;
end Create_And_Populate;
-----------
-- Error --
-----------
procedure Error (R : String; Msg : String) is
begin
Put_Line ("ERROR: " & R & ": " & Msg);
end Error;
---------------
-- Hash_Edge --
---------------
function Hash_Edge (E : Edge_Id) return Bucket_Range_Type is
begin
return Bucket_Range_Type (Edge_Id'Pos (E));
end Hash_Edge;
-----------------
-- Hash_Vertex --
-----------------
function Hash_Vertex (V : Vertex_Id) return Bucket_Range_Type is
begin
return Bucket_Range_Type (Vertex_Id'Pos (V));
end Hash_Vertex;
-------------------
-- Test_Add_Edge --
-------------------
procedure Test_Add_Edge is
R : constant String := "Test_Add_Edge";
E : Edge_Id;
G : Instance := Create_And_Populate;
All_E_Iter : All_Edge_Iterator;
Out_E_Iter : Outgoing_Edge_Iterator;
begin
-- Try to add the same edge twice
begin
Add_Edge (G, E1, VB, VH);
Error (R, "duplicate edge not detected");
exception
when Duplicate_Edge => null;
when others => Unexpected_Exception (R);
end;
-- Try to add an edge with a bogus source
begin
Add_Edge (G, E97, Source => VX, Destination => VC);
Error (R, "missing vertex not detected");
exception
when Missing_Vertex => null;
when others => Unexpected_Exception (R);
end;
-- Try to add an edge with a bogus destination
begin
Add_Edge (G, E97, Source => VF, Destination => VY);
Error (R, "missing vertex not detected");
exception
when Missing_Vertex => null;
when others => Unexpected_Exception (R);
end;
-- Delete edge E1 between vertices VA and VB
begin
Delete_Edge (G, E1);
exception
when others => Unexpected_Exception (R);
end;
-- Try to re-add edge E1
begin
Add_Edge (G, E1, Source => VA, Destination => VB);
exception
when others => Unexpected_Exception (R);
end;
-- Lock all edges in the graph
All_E_Iter := Iterate_All_Edges (G);
-- Try to add an edge given that all edges are locked
begin
Add_Edge (G, E97, Source => VG, Destination => VH);
Error (R, "all edges not locked");
exception
when Iterated => null;
when others => Unexpected_Exception (R);
end;
-- Unlock all edges by iterating over them
while Has_Next (All_E_Iter) loop Next (All_E_Iter, E); end loop;
-- Lock all outgoing edges of vertex VD
Out_E_Iter := Iterate_Outgoing_Edges (G, VD);
-- Try to add an edge with source VD given that all edges of VD are
-- locked.
begin
Add_Edge (G, E97, Source => VD, Destination => VG);
Error (R, "outgoing edges of VD not locked");
exception
when Iterated => null;
when others => Unexpected_Exception (R);
end;
-- Unlock the edges of vertex VD by iterating over them
while Has_Next (Out_E_Iter) loop Next (Out_E_Iter, E); end loop;
Destroy (G);
end Test_Add_Edge;
---------------------
-- Test_Add_Vertex --
---------------------
procedure Test_Add_Vertex is
R : constant String := "Test_Add_Vertex";
G : Instance := Create_And_Populate;
V : Vertex_Id;
All_V_Iter : All_Vertex_Iterator;
begin
-- Try to add the same vertex twice
begin
Add_Vertex (G, VD);
Error (R, "duplicate vertex not detected");
exception
when Duplicate_Vertex => null;
when others => Unexpected_Exception (R);
end;
-- Lock all vertices in the graph
All_V_Iter := Iterate_All_Vertices (G);
-- Try to add a vertex given that all vertices are locked
begin
Add_Vertex (G, VZ);
Error (R, "all vertices not locked");
exception
when Iterated => null;
when others => Unexpected_Exception (R);
end;
-- Unlock all vertices by iterating over them
while Has_Next (All_V_Iter) loop Next (All_V_Iter, V); end loop;
Destroy (G);
end Test_Add_Vertex;
----------------------------
-- Test_All_Edge_Iterator --
----------------------------
procedure Test_All_Edge_Iterator is
R : constant String := "Test_All_Edge_Iterator";
E : Edge_Id;
G : Instance := Create_And_Populate;
All_E_Iter : All_Edge_Iterator;
All_Edges : ES.Instance;
begin
-- Collect all expected edges in a set
All_Edges := ES.Create (Number_Of_Edges (G));
for Curr_E in E1 .. E10 loop
ES.Insert (All_Edges, Curr_E);
end loop;
-- Iterate over all edges while removing encountered edges from the set
All_E_Iter := Iterate_All_Edges (G);
while Has_Next (All_E_Iter) loop
Next (All_E_Iter, E);
if ES.Contains (All_Edges, E) then
ES.Delete (All_Edges, E);
else
Error (R, "edge " & E'Img & " is not iterated");
end if;
end loop;
-- At this point the set of edges should be empty
if not ES.Is_Empty (All_Edges) then
Error (R, "not all edges were iterated");
end if;
ES.Destroy (All_Edges);
Destroy (G);
end Test_All_Edge_Iterator;
------------------------------
-- Test_All_Vertex_Iterator --
------------------------------
procedure Test_All_Vertex_Iterator is
R : constant String := "Test_All_Vertex_Iterator";
G : Instance := Create_And_Populate;
V : Vertex_Id;
All_V_Iter : All_Vertex_Iterator;
All_Vertices : VS.Instance;
begin
-- Collect all expected vertices in a set
All_Vertices := VS.Create (Number_Of_Vertices (G));
for Curr_V in VA .. VH loop
VS.Insert (All_Vertices, Curr_V);
end loop;
-- Iterate over all vertices while removing encountered vertices from
-- the set.
All_V_Iter := Iterate_All_Vertices (G);
while Has_Next (All_V_Iter) loop
Next (All_V_Iter, V);
if VS.Contains (All_Vertices, V) then
VS.Delete (All_Vertices, V);
else
Error (R, "vertex " & V'Img & " is not iterated");
end if;
end loop;
-- At this point the set of vertices should be empty
if not VS.Is_Empty (All_Vertices) then
Error (R, "not all vertices were iterated");
end if;
VS.Destroy (All_Vertices);
Destroy (G);
end Test_All_Vertex_Iterator;
--------------------
-- Test_Component --
--------------------
procedure Test_Component is
R : constant String := "Test_Component";
G : Instance := Create (Initial_Vertices => 3, Initial_Edges => 2);
begin
-- E1
-- ----->
-- VA VB VC
-- <-----
-- E2
--
-- Components:
--
-- [VA, VB]
-- [VC]
Add_Vertex (G, VA);
Add_Vertex (G, VB);
Add_Vertex (G, VC);
Add_Edge (G, E1, Source => VA, Destination => VB);
Add_Edge (G, E2, Source => VB, Destination => VA);
-- None of the vertices should belong to a component
Check_No_Component (R, G, VA);
Check_No_Component (R, G, VB);
Check_No_Component (R, G, VC);
-- Find the strongly connected components in the graph
Find_Components (G);
-- Vertices should belong to a component
Check_Belongs_To_Some_Component (R, G, VA);
Check_Belongs_To_Some_Component (R, G, VB);
Check_Belongs_To_Some_Component (R, G, VC);
Destroy (G);
end Test_Component;
-----------------------------
-- Test_Component_Iterator --
-----------------------------
procedure Test_Component_Iterator is
R : constant String := "Test_Component_Iterator";
G : Instance := Create_And_Populate;
Comp : Component_Id;
Comp_Count : Natural;
Comp_Iter : Component_Iterator;
begin
Find_Components (G);
Check_Number_Of_Components (R, G, 5);
Comp_Count := Number_Of_Components (G);
-- Iterate over all components while decrementing their number
Comp_Iter := Iterate_Components (G);
while Has_Next (Comp_Iter) loop
Next (Comp_Iter, Comp);
Comp_Count := Comp_Count - 1;
end loop;
-- At this point all components should have been accounted for
if Comp_Count /= 0 then
Error (R, "not all components were iterated");
end if;
Destroy (G);
end Test_Component_Iterator;
-----------------------------
-- Test_Contains_Component --
-----------------------------
procedure Test_Contains_Component is
R : constant String := "Test_Contains_Component";
G1 : Instance := Create (Initial_Vertices => 2, Initial_Edges => 2);
G2 : Instance := Create (Initial_Vertices => 2, Initial_Edges => 2);
begin
-- E1
-- ----->
-- VA VB
-- <-----
-- E2
--
-- Components:
--
-- [VA, VB]
Add_Vertex (G1, VA);
Add_Vertex (G1, VB);
Add_Edge (G1, E1, Source => VA, Destination => VB);
Add_Edge (G1, E2, Source => VB, Destination => VA);
-- E97
-- ----->
-- VX VY
-- <-----
-- E98
--
-- Components:
--
-- [VX, VY]
Add_Vertex (G2, VX);
Add_Vertex (G2, VY);
Add_Edge (G2, E97, Source => VX, Destination => VY);
Add_Edge (G2, E98, Source => VY, Destination => VX);
-- Find the strongly connected components in both graphs
Find_Components (G1);
Find_Components (G2);
-- Vertices should belong to a component
Check_Belongs_To_Some_Component (R, G1, VA);
Check_Belongs_To_Some_Component (R, G1, VB);
Check_Belongs_To_Some_Component (R, G2, VX);
Check_Belongs_To_Some_Component (R, G2, VY);
-- Verify that each graph contains the correct component
Check_Has_Component (R, G1, "G1", Component (G1, VA));
Check_Has_Component (R, G1, "G1", Component (G1, VB));
Check_Has_Component (R, G2, "G2", Component (G2, VX));
Check_Has_Component (R, G2, "G2", Component (G2, VY));
-- Verify that each graph does not contain components from the other
-- graph.
Check_No_Component (R, G1, "G1", Component (G2, VX));
Check_No_Component (R, G1, "G1", Component (G2, VY));
Check_No_Component (R, G2, "G2", Component (G1, VA));
Check_No_Component (R, G2, "G2", Component (G1, VB));
Destroy (G1);
Destroy (G2);
end Test_Contains_Component;
------------------------
-- Test_Contains_Edge --
------------------------
procedure Test_Contains_Edge is
R : constant String := "Test_Contains_Edge";
G : Instance := Create_And_Populate;
begin
-- Verify that all edges in the range E1 .. E10 exist
for Curr_E in E1 .. E10 loop
Check_Has_Edge (R, G, Curr_E);
end loop;
-- Verify that no extra edges are present
for Curr_E in E97 .. E99 loop
Check_No_Edge (R, G, Curr_E);
end loop;
-- Add new edges E97, E98, and E99
Add_Edge (G, E97, Source => VG, Destination => VF);
Add_Edge (G, E98, Source => VH, Destination => VE);
Add_Edge (G, E99, Source => VD, Destination => VC);
-- Verify that all edges in the range E1 .. E99 exist
for Curr_E in E1 .. E99 loop
Check_Has_Edge (R, G, Curr_E);
end loop;
-- Delete each edge that corresponds to an even position in Edge_Id
for Curr_E in E1 .. E99 loop
if Edge_Id'Pos (Curr_E) mod 2 = 0 then
Delete_Edge (G, Curr_E);
end if;
end loop;
-- Verify that all "even" edges are missing, and all "odd" edges are
-- present.
for Curr_E in E1 .. E99 loop
if Edge_Id'Pos (Curr_E) mod 2 = 0 then
Check_No_Edge (R, G, Curr_E);
else
Check_Has_Edge (R, G, Curr_E);
end if;
end loop;
Destroy (G);
end Test_Contains_Edge;
--------------------------
-- Test_Contains_Vertex --
--------------------------
procedure Test_Contains_Vertex is
R : constant String := "Test_Contains_Vertex";
G : Instance := Create_And_Populate;
begin
-- Verify that all vertices in the range VA .. VH exist
for Curr_V in VA .. VH loop
Check_Has_Vertex (R, G, Curr_V);
end loop;
-- Verify that no extra vertices are present
for Curr_V in VX .. VZ loop
Check_No_Vertex (R, G, Curr_V);
end loop;
-- Add new vertices VX, VY, and VZ
Add_Vertex (G, VX);
Add_Vertex (G, VY);
Add_Vertex (G, VZ);
-- Verify that all vertices in the range VA .. VZ exist
for Curr_V in VA .. VZ loop
Check_Has_Vertex (R, G, Curr_V);
end loop;
Destroy (G);
end Test_Contains_Vertex;
----------------------
-- Test_Delete_Edge --
----------------------
procedure Test_Delete_Edge is
R : constant String := "Test_Delete_Edge";
E : Edge_Id;
G : Instance := Create_And_Populate;
V : Vertex_Id;
All_E_Iter : All_Edge_Iterator;
All_V_Iter : All_Vertex_Iterator;
Out_E_Iter : Outgoing_Edge_Iterator;
begin
-- Try to delete a bogus edge
begin
Delete_Edge (G, E97);
Error (R, "missing vertex deleted");
exception
when Missing_Edge => null;
when others => Unexpected_Exception (R);
end;
-- Delete edge E1 between vertices VA and VB
begin
Delete_Edge (G, E1);
exception
when others => Unexpected_Exception (R);
end;
-- Verify that edge E1 is gone from all edges in the graph
All_E_Iter := Iterate_All_Edges (G);
while Has_Next (All_E_Iter) loop
Next (All_E_Iter, E);
if E = E1 then
Error (R, "edge " & E'Img & " not removed from all edges");
end if;
end loop;
-- Verify that edge E1 is gone from the outgoing edges of vertex VA
Out_E_Iter := Iterate_Outgoing_Edges (G, VA);
while Has_Next (Out_E_Iter) loop
Next (Out_E_Iter, E);
if E = E1 then
Error
(R, "edge " & E'Img & "not removed from outgoing edges of VA");
end if;
end loop;
-- Delete all edges in the range E2 .. E10
for Curr_E in E2 .. E10 loop
Delete_Edge (G, Curr_E);
end loop;
-- Verify that all edges are gone from the graph
All_E_Iter := Iterate_All_Edges (G);
while Has_Next (All_E_Iter) loop
Next (All_E_Iter, E);
Error (R, "edge " & E'Img & " not removed from all edges");
end loop;
-- Verify that all edges are gone from the respective source vertices
All_V_Iter := Iterate_All_Vertices (G);
while Has_Next (All_V_Iter) loop
Next (All_V_Iter, V);
Out_E_Iter := Iterate_Outgoing_Edges (G, V);
while Has_Next (Out_E_Iter) loop
Next (Out_E_Iter, E);
Error (R, "edge " & E'Img & " not removed from vertex " & V'Img);
end loop;
end loop;
Destroy (G);
end Test_Delete_Edge;
-----------------------------
-- Test_Destination_Vertex --
-----------------------------
procedure Test_Destination_Vertex is
R : constant String := "Test_Destination_Vertex";
G : Instance := Create_And_Populate;
begin
-- Verify the destination vertices of all edges in the graph
Check_Destination_Vertex (R, G, E1, VB);
Check_Destination_Vertex (R, G, E2, VC);
Check_Destination_Vertex (R, G, E3, VC);
Check_Destination_Vertex (R, G, E4, VD);
Check_Destination_Vertex (R, G, E5, VB);
Check_Destination_Vertex (R, G, E6, VE);
Check_Destination_Vertex (R, G, E7, VD);
Check_Destination_Vertex (R, G, E8, VF);
Check_Destination_Vertex (R, G, E9, VG);
Check_Destination_Vertex (R, G, E10, VA);
Destroy (G);
end Test_Destination_Vertex;
--------------------------
-- Test_Find_Components --
--------------------------
procedure Test_Find_Components is
R : constant String := "Test_Find_Components";
G : Instance := Create_And_Populate;
Comp_1 : Component_Id; -- [A, F, G]
Comp_2 : Component_Id; -- [B]
Comp_3 : Component_Id; -- [C]
Comp_4 : Component_Id; -- [D, E]
Comp_5 : Component_Id; -- [H]
begin
Find_Components (G);
-- Vertices should belong to a component
Check_Belongs_To_Some_Component (R, G, VA);
Check_Belongs_To_Some_Component (R, G, VB);
Check_Belongs_To_Some_Component (R, G, VC);
Check_Belongs_To_Some_Component (R, G, VD);
Check_Belongs_To_Some_Component (R, G, VH);
-- Extract the ids of the components from the first vertices in each
-- component.
Comp_1 := Component (G, VA);
Comp_2 := Component (G, VB);
Comp_3 := Component (G, VC);
Comp_4 := Component (G, VD);
Comp_5 := Component (G, VH);
-- Verify that the components are distinct
Check_Distinct_Components (R, Comp_1, Comp_2);
Check_Distinct_Components (R, Comp_1, Comp_3);
Check_Distinct_Components (R, Comp_1, Comp_4);
Check_Distinct_Components (R, Comp_1, Comp_5);
Check_Distinct_Components (R, Comp_2, Comp_3);
Check_Distinct_Components (R, Comp_2, Comp_4);
Check_Distinct_Components (R, Comp_2, Comp_5);
Check_Distinct_Components (R, Comp_3, Comp_4);
Check_Distinct_Components (R, Comp_3, Comp_5);
Check_Distinct_Components (R, Comp_4, Comp_5);
-- Verify that the remaining nodes belong to the proper component
Check_Belongs_To_Component (R, G, VF, Comp_1);
Check_Belongs_To_Component (R, G, VG, Comp_1);
Check_Belongs_To_Component (R, G, VE, Comp_4);
Destroy (G);
end Test_Find_Components;
-------------------
-- Test_Is_Empty --
-------------------
procedure Test_Is_Empty is
R : constant String := "Test_Is_Empty";
G : Instance := Create (Initial_Vertices => 3, Initial_Edges => 2);
begin
-- Verify that a graph without vertices and edges is empty
if not Is_Empty (G) then
Error (R, "graph is empty");
end if;
-- Add vertices
Add_Vertex (G, VA);
Add_Vertex (G, VB);
-- Verify that a graph with vertices and no edges is not empty
if Is_Empty (G) then
Error (R, "graph is not empty");
end if;
-- Add edges
Add_Edge (G, E1, Source => VA, Destination => VB);
-- Verify that a graph with vertices and edges is not empty
if Is_Empty (G) then
Error (R, "graph is not empty");
end if;
Destroy (G);
end Test_Is_Empty;
-------------------------------
-- Test_Number_Of_Components --
-------------------------------
procedure Test_Number_Of_Components is
R : constant String := "Test_Number_Of_Components";
G : Instance := Create (Initial_Vertices => 3, Initial_Edges => 2);
begin
-- Verify that an empty graph has exactly 0 components
Check_Number_Of_Components (R, G, 0);
-- E1
-- ----->
-- VA VB VC
-- <-----
-- E2
--
-- Components:
--
-- [VA, VB]
-- [VC]
Add_Vertex (G, VA);
Add_Vertex (G, VB);
Add_Vertex (G, VC);
Add_Edge (G, E1, Source => VA, Destination => VB);
Add_Edge (G, E2, Source => VB, Destination => VA);
-- Verify that the graph has exact 0 components even though it contains
-- vertices and edges.
Check_Number_Of_Components (R, G, 0);
Find_Components (G);
-- Verify that the graph has exactly 2 components
Check_Number_Of_Components (R, G, 2);
Destroy (G);
end Test_Number_Of_Components;
--------------------------
-- Test_Number_Of_Edges --
--------------------------
procedure Test_Number_Of_Edges is
R : constant String := "Test_Number_Of_Edges";
G : Instance := Create_And_Populate;
begin
-- Verify that the graph has exactly 10 edges
Check_Number_Of_Edges (R, G, 10);
-- Delete two edges
Delete_Edge (G, E1);
Delete_Edge (G, E2);
-- Verify that the graph has exactly 8 edges
Check_Number_Of_Edges (R, G, 8);
-- Delete the remaining edge
for Curr_E in E3 .. E10 loop
Delete_Edge (G, Curr_E);
end loop;
-- Verify that the graph has exactly 0 edges
Check_Number_Of_Edges (R, G, 0);
-- Add two edges
Add_Edge (G, E1, Source => VF, Destination => VA);
Add_Edge (G, E2, Source => VC, Destination => VH);
-- Verify that the graph has exactly 2 edges
Check_Number_Of_Edges (R, G, 2);
Destroy (G);
end Test_Number_Of_Edges;
-----------------------------
-- Test_Number_Of_Vertices --
-----------------------------
procedure Test_Number_Of_Vertices is
R : constant String := "Test_Number_Of_Vertices";
G : Instance := Create (Initial_Vertices => 4, Initial_Edges => 12);
begin
-- Verify that an empty graph has exactly 0 vertices
Check_Number_Of_Vertices (R, G, 0);
-- Add three vertices
Add_Vertex (G, VC);
Add_Vertex (G, VG);
Add_Vertex (G, VX);
-- Verify that the graph has exactly 3 vertices
Check_Number_Of_Vertices (R, G, 3);
-- Add one edge
Add_Edge (G, E8, Source => VX, Destination => VG);
-- Verify that the graph has exactly 3 vertices
Check_Number_Of_Vertices (R, G, 3);
Destroy (G);
end Test_Number_Of_Vertices;
---------------------------------
-- Test_Outgoing_Edge_Iterator --
---------------------------------
procedure Test_Outgoing_Edge_Iterator is
R : constant String := "Test_Outgoing_Edge_Iterator";
G : Instance := Create_And_Populate;
Set : ES.Instance;
begin
Set := ES.Create (4);
ES.Insert (Set, E1);
ES.Insert (Set, E3);
ES.Insert (Set, E4);
ES.Insert (Set, E8);
Check_Outgoing_Edge_Iterator (R, G, VA, Set);
ES.Insert (Set, E2);
Check_Outgoing_Edge_Iterator (R, G, VB, Set);
Check_Outgoing_Edge_Iterator (R, G, VC, Set);
ES.Insert (Set, E5);
ES.Insert (Set, E6);
Check_Outgoing_Edge_Iterator (R, G, VD, Set);
ES.Insert (Set, E7);
Check_Outgoing_Edge_Iterator (R, G, VE, Set);
ES.Insert (Set, E9);
Check_Outgoing_Edge_Iterator (R, G, VF, Set);
ES.Insert (Set, E10);
Check_Outgoing_Edge_Iterator (R, G, VG, Set);
Check_Outgoing_Edge_Iterator (R, G, VH, Set);
ES.Destroy (Set);
Destroy (G);
end Test_Outgoing_Edge_Iterator;
------------------
-- Test_Present --
------------------
procedure Test_Present is
R : constant String := "Test_Present";
G : Instance := Nil;
begin
-- Verify that a non-existent graph is not present
if Present (G) then
Error (R, "graph is not present");
end if;
G := Create_And_Populate;
-- Verify that an existing graph is present
if not Present (G) then
Error (R, "graph is present");
end if;
Destroy (G);
-- Verify that a destroyed graph is not present
if Present (G) then
Error (R, "graph is not present");
end if;
end Test_Present;
------------------------
-- Test_Source_Vertex --
------------------------
procedure Test_Source_Vertex is
R : constant String := "Test_Source_Vertex";
G : Instance := Create_And_Populate;
begin
-- Verify the source vertices of all edges in the graph
Check_Source_Vertex (R, G, E1, VA);
Check_Source_Vertex (R, G, E2, VB);
Check_Source_Vertex (R, G, E3, VA);
Check_Source_Vertex (R, G, E4, VA);
Check_Source_Vertex (R, G, E5, VD);
Check_Source_Vertex (R, G, E6, VD);
Check_Source_Vertex (R, G, E7, VE);
Check_Source_Vertex (R, G, E8, VA);
Check_Source_Vertex (R, G, E9, VF);
Check_Source_Vertex (R, G, E10, VG);
Destroy (G);
end Test_Source_Vertex;
--------------------------
-- Test_Vertex_Iterator --
--------------------------
procedure Test_Vertex_Iterator is
R : constant String := "Test_Vertex_Iterator";
G : Instance := Create_And_Populate;
Set : VS.Instance;
begin
Find_Components (G);
Set := VS.Create (3);
VS.Insert (Set, VA);
VS.Insert (Set, VF);
VS.Insert (Set, VG);
Check_Vertex_Iterator (R, G, Component (G, VA), Set);
VS.Insert (Set, VB);
Check_Vertex_Iterator (R, G, Component (G, VB), Set);
VS.Insert (Set, VC);
Check_Vertex_Iterator (R, G, Component (G, VC), Set);
VS.Insert (Set, VD);
VS.Insert (Set, VE);
Check_Vertex_Iterator (R, G, Component (G, VD), Set);
VS.Insert (Set, VH);
Check_Vertex_Iterator (R, G, Component (G, VH), Set);
VS.Destroy (Set);
Destroy (G);
end Test_Vertex_Iterator;
--------------------------
-- Unexpected_Exception --
--------------------------
procedure Unexpected_Exception (R : String) is
begin
Error (R, "unexpected exception");
end Unexpected_Exception;
-- Start of processing for Operations
begin
Test_Add_Edge;
Test_Add_Vertex;
Test_All_Edge_Iterator;
Test_All_Vertex_Iterator;
Test_Component;
Test_Component_Iterator;
Test_Contains_Component;
Test_Contains_Edge;
Test_Contains_Vertex;
Test_Delete_Edge;
Test_Destination_Vertex;
Test_Find_Components;
Test_Is_Empty;
Test_Number_Of_Components;
Test_Number_Of_Edges;
Test_Number_Of_Vertices;
Test_Outgoing_Edge_Iterator;
Test_Present;
Test_Source_Vertex;
Test_Vertex_Iterator;
end Operations;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q operations.adb -largs -lgmem
$ ./operations
$ gnatmem operations > leaks.txt
$ grep -c "non freed allocations" leaks.txt
0
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* impunit.adb: Add GNAT.Graphs to list Non_Imp_File_Names_95.
* Makefile.rtl, gcc-interface/Make-lang.in: Register unit
GNAT.Graphs.
* libgnat/g-dynhta.adb: Various minor cleanups (use Present
rather than direct comparisons).
(Delete): Reimplement to use Delete_Node.
(Delete_Node): New routine.
(Destroy_Bucket): Invoke the provided destructor.
(Present): New routines.
* libgnat/g-dynhta.ads: Add new generic formal Destroy_Value.
Use better names for the components of iterators.
* libgnat/g-graphs.adb, libgnat/g-graphs.ads: New unit.
* libgnat/g-lists.adb: Various minor cleanups (use Present
rather than direct comparisons).
(Delete_Node): Invoke the provided destructor.
(Present): New routine.
* libgnat/g-lists.ads: Add new generic formal Destroy_Element.
Use better names for the components of iterators.
(Present): New routine.
* libgnat/g-sets.adb, libgnat/g-sets.ads (Destroy, Preset,
Reset): New routines.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@272857
138bc75d-0d04-0410-961f-
82ee72b054a4
+2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * impunit.adb: Add GNAT.Graphs to list Non_Imp_File_Names_95.
+ * Makefile.rtl, gcc-interface/Make-lang.in: Register unit
+ GNAT.Graphs.
+ * libgnat/g-dynhta.adb: Various minor cleanups (use Present
+ rather than direct comparisons).
+ (Delete): Reimplement to use Delete_Node.
+ (Delete_Node): New routine.
+ (Destroy_Bucket): Invoke the provided destructor.
+ (Present): New routines.
+ * libgnat/g-dynhta.ads: Add new generic formal Destroy_Value.
+ Use better names for the components of iterators.
+ * libgnat/g-graphs.adb, libgnat/g-graphs.ads: New unit.
+ * libgnat/g-lists.adb: Various minor cleanups (use Present
+ rather than direct comparisons).
+ (Delete_Node): Invoke the provided destructor.
+ (Present): New routine.
+ * libgnat/g-lists.ads: Add new generic formal Destroy_Element.
+ Use better names for the components of iterators.
+ (Present): New routine.
+ * libgnat/g-sets.adb, libgnat/g-sets.ads (Destroy, Preset,
+ Reset): New routines.
+
2019-07-01 Dmitriy Anisimkov <anisimko@adacore.com>
* libgnat/g-sothco.adb (Get_Address): Fix the case when AF_INET6
g-exptty$(objext) \
g-flocon$(objext) \
g-forstr$(objext) \
+ g-graphs$(objext) \
g-heasor$(objext) \
g-hesora$(objext) \
g-hesorg$(objext) \
ada/frontend.o \
ada/libgnat/g-byorma.o \
ada/libgnat/g-dynhta.o \
+ ada/libgnat/g-graphs.o \
ada/libgnat/g-hesora.o \
ada/libgnat/g-htable.o \
ada/libgnat/g-lists.o \
("g-exptty", F), -- GNAT.Expect.TTY
("g-flocon", F), -- GNAT.Float_Control
("g-forstr", F), -- GNAT.Formatted_String
+ ("g-graphs", F), -- GNAT.Graphs
("g-heasor", F), -- GNAT.Heap_Sort
("g-hesora", F), -- GNAT.Heap_Sort_A
("g-hesorg", F), -- GNAT.Heap_Sort_G
-- Maximum safe size for hash table expansion. Beyond this size, an
-- expansion will overflow the buckets.
+ procedure Delete_Node (T : Instance; Nod : Node_Ptr);
+ pragma Inline (Delete_Node);
+ -- Detach and delete node Nod from table T
+
procedure Destroy_Buckets (Bkts : Bucket_Table_Ptr);
pragma Inline (Destroy_Buckets);
-- Destroy all nodes within buckets Bkts
pragma Inline (Prepend);
-- Insert node Nod immediately after dummy head Head
+ function Present (Bkts : Bucket_Table_Ptr) return Boolean;
+ pragma Inline (Present);
+ -- Determine whether buckets Bkts exist
+
+ function Present (Nod : Node_Ptr) return Boolean;
+ pragma Inline (Present);
+ -- Determine whether node Nod exists
+
procedure Unlock (T : Instance);
pragma Inline (Unlock);
-- Unlock all mutation functionality of hash table T
------------
procedure Delete (T : Instance; Key : Key_Type) is
+ Head : Node_Ptr;
+ Nod : Node_Ptr;
+
+ begin
+ Ensure_Created (T);
+ Ensure_Unlocked (T);
+
+ -- Obtain the dummy head of the bucket which should house the
+ -- key-value pair.
+
+ Head := Find_Bucket (T.Buckets, Key);
+
+ -- Try to find a node in the bucket which matches the key
+
+ Nod := Find_Node (Head, Key);
+
+ -- If such a node exists, remove it from the bucket and deallocate it
+
+ if Is_Valid (Nod, Head) then
+ Delete_Node (T, Nod);
+ end if;
+ end Delete;
+
+ -----------------
+ -- Delete_Node --
+ -----------------
+
+ procedure Delete_Node (T : Instance; Nod : Node_Ptr) is
procedure Compress;
pragma Inline (Compress);
-- Determine whether hash table T requires compression, and if so,
--------------
procedure Compress is
- pragma Assert (T /= null);
- pragma Assert (T.Buckets /= null);
+ pragma Assert (Present (T));
+ pragma Assert (Present (T.Buckets));
Old_Size : constant Bucket_Range_Type := T.Buckets'Length;
-- Local variables
- Head : Node_Ptr;
- Nod : Node_Ptr;
+ Ref : Node_Ptr := Nod;
- -- Start of processing for Delete
+ -- Start of processing for Delete_Node
begin
- Ensure_Created (T);
- Ensure_Unlocked (T);
+ pragma Assert (Present (Ref));
+ pragma Assert (Present (T));
- -- Obtain the dummy head of the bucket which should house the
- -- key-value pair.
-
- Head := Find_Bucket (T.Buckets, Key);
-
- -- Try to find a node in the bucket which matches the key
-
- Nod := Find_Node (Head, Key);
+ Detach (Ref);
+ Free (Ref);
- -- If such a node exists, remove it from the bucket and deallocate it
-
- if Is_Valid (Nod, Head) then
- Detach (Nod);
- Free (Nod);
-
- -- The number of key-value pairs is updated when the hash table
- -- contains a valid node which represents the pair.
+ -- The number of key-value pairs is updated when the hash table
+ -- contains a valid node which represents the pair.
- T.Pairs := T.Pairs - 1;
+ T.Pairs := T.Pairs - 1;
- -- Compress the hash table if the load factor drops below
- -- Compression_Threshold.
+ -- Compress the hash table if the load factor drops below the value
+ -- of Compression_Threshold.
- Compress;
- end if;
- end Delete;
+ Compress;
+ end Delete_Node;
-------------
-- Destroy --
while Is_Valid (Head.Next, Head) loop
Nod := Head.Next;
+ -- Invoke the value destructor before deallocating the node
+
+ Destroy_Value (Nod.Value);
+
Detach (Nod);
Free (Nod);
end loop;
-- Start of processing for Destroy_Buckets
begin
- pragma Assert (Bkts /= null);
+ pragma Assert (Present (Bkts));
for Scan_Idx in Bkts'Range loop
Destroy_Bucket (Bkts (Scan_Idx)'Access);
------------
procedure Detach (Nod : Node_Ptr) is
- pragma Assert (Nod /= null);
+ pragma Assert (Present (Nod));
Next : constant Node_Ptr := Nod.Next;
Prev : constant Node_Ptr := Nod.Prev;
begin
- pragma Assert (Next /= null);
- pragma Assert (Prev /= null);
+ pragma Assert (Present (Next));
+ pragma Assert (Present (Prev));
- Prev.Next := Next;
- Next.Prev := Prev;
+ Prev.Next := Next; -- Prev ---> Next
+ Next.Prev := Prev; -- Prev <--> Next
Nod.Next := null;
Nod.Prev := null;
---------------------
procedure Ensure_Circular (Head : Node_Ptr) is
- pragma Assert (Head /= null);
+ pragma Assert (Present (Head));
begin
- if Head.Next = null and then Head.Prev = null then
+ if not Present (Head.Next) and then not Present (Head.Prev) then
Head.Next := Head;
Head.Prev := Head;
end if;
procedure Ensure_Created (T : Instance) is
begin
- if T = null then
+ if not Present (T) then
raise Not_Created;
end if;
end Ensure_Created;
procedure Ensure_Unlocked (T : Instance) is
begin
- pragma Assert (T /= null);
+ pragma Assert (Present (T));
-- The hash table has at least one outstanding iterator
(Bkts : Bucket_Table_Ptr;
Key : Key_Type) return Node_Ptr
is
- pragma Assert (Bkts /= null);
+ pragma Assert (Present (Bkts));
Idx : constant Bucket_Range_Type := Hash (Key) mod Bkts'Length;
---------------
function Find_Node (Head : Node_Ptr; Key : Key_Type) return Node_Ptr is
- pragma Assert (Head /= null);
+ pragma Assert (Present (Head));
Nod : Node_Ptr;
Head : Node_Ptr;
begin
- pragma Assert (T /= null);
- pragma Assert (T.Buckets /= null);
+ pragma Assert (Present (T));
+ pragma Assert (Present (T.Buckets));
-- Assume that no valid node exists
T : constant Instance := Iter.Table;
begin
- pragma Assert (T /= null);
+ pragma Assert (Present (T));
-- The iterator is no longer valid which indicates that it has been
-- exhausted. Unlock all mutation functionality of the hash table
-- The invariant of Iterate and Next ensures that the iterator always
-- refers to a valid node if there exists one.
- return Iter.Nod /= null;
+ return Present (Iter.Curr_Nod);
end Is_Valid;
--------------
-- A node is valid if it is non-null, and does not refer to the dummy
-- head of some bucket.
- return Nod /= null and then Nod /= Head;
+ return Present (Nod) and then Nod /= Head;
end Is_Valid;
-------------
begin
Ensure_Created (T);
- pragma Assert (T.Buckets /= null);
+ pragma Assert (Present (T.Buckets));
-- Initialize the iterator to reference the first valid node in
-- the full range of hash table buckets. If no such node exists,
(T => T,
Low_Bkt => T.Buckets'First,
High_Bkt => T.Buckets'Last,
- Idx => Iter.Idx,
- Nod => Iter.Nod);
+ Idx => Iter.Curr_Idx,
+ Nod => Iter.Curr_Nod);
-- Associate the iterator with the hash table to allow for future
-- mutation functionality unlocking.
-----------------
function Load_Factor (T : Instance) return Threshold_Type is
- pragma Assert (T /= null);
- pragma Assert (T.Buckets /= null);
+ pragma Assert (Present (T));
+ pragma Assert (Present (T.Buckets));
begin
-- The load factor is the ratio of key-value pairs to buckets
procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr) is
begin
- pragma Assert (From /= null);
- pragma Assert (To /= null);
+ pragma Assert (Present (From));
+ pragma Assert (Present (To));
for Scan_Idx in From'Range loop
Rehash_Bucket (From (Scan_Idx)'Access, To);
-------------------
procedure Rehash_Bucket (Head : Node_Ptr; To : Bucket_Table_Ptr) is
- pragma Assert (Head /= null);
+ pragma Assert (Present (Head));
Nod : Node_Ptr;
-----------------
procedure Rehash_Node (Nod : Node_Ptr; To : Bucket_Table_Ptr) is
- pragma Assert (Nod /= null);
+ pragma Assert (Present (Nod));
Head : Node_Ptr;
-- Start of processing for Mutate_And_Rehash
begin
- pragma Assert (T /= null);
+ pragma Assert (Present (T));
Old_Bkts := T.Buckets;
T.Buckets := new Bucket_Table (0 .. Size - 1);
procedure Next (Iter : in out Iterator; Key : out Key_Type) is
Is_OK : constant Boolean := Is_Valid (Iter);
- Saved : constant Node_Ptr := Iter.Nod;
+ Saved : constant Node_Ptr := Iter.Curr_Nod;
T : constant Instance := Iter.Table;
Head : Node_Ptr;
begin
- pragma Assert (T /= null);
- pragma Assert (T.Buckets /= null);
+ pragma Assert (Present (T));
+ pragma Assert (Present (T.Buckets));
-- The iterator is no longer valid which indicates that it has been
-- exhausted. Unlock all mutation functionality of the hash table as
-- Advance to the next node along the same bucket
- Iter.Nod := Iter.Nod.Next;
- Head := T.Buckets (Iter.Idx)'Access;
+ Iter.Curr_Nod := Iter.Curr_Nod.Next;
+ Head := T.Buckets (Iter.Curr_Idx)'Access;
-- If the new node is no longer valid, then this indicates that the
-- current bucket has been exhausted. Advance to the next valid node
-- within the remaining range of buckets. If no such node exists, the
-- iterator is left in a state which does not allow it to advance.
- if not Is_Valid (Iter.Nod, Head) then
+ if not Is_Valid (Iter.Curr_Nod, Head) then
First_Valid_Node
- (T => T,
- Low_Bkt => Iter.Idx + 1,
+ (T => T,
+ Low_Bkt => Iter.Curr_Idx + 1,
High_Bkt => T.Buckets'Last,
- Idx => Iter.Idx,
- Nod => Iter.Nod);
+ Idx => Iter.Curr_Idx,
+ Nod => Iter.Curr_Nod);
end if;
Key := Saved.Key;
-------------
procedure Prepend (Nod : Node_Ptr; Head : Node_Ptr) is
- pragma Assert (Nod /= null);
- pragma Assert (Head /= null);
+ pragma Assert (Present (Nod));
+ pragma Assert (Present (Head));
Next : constant Node_Ptr := Head.Next;
Nod.Prev := Head;
end Prepend;
+ -------------
+ -- Present --
+ -------------
+
+ function Present (Bkts : Bucket_Table_Ptr) return Boolean is
+ begin
+ return Bkts /= null;
+ end Present;
+
+ -------------
+ -- Present --
+ -------------
+
+ function Present (Nod : Node_Ptr) return Boolean is
+ begin
+ return Nod /= null;
+ end Present;
+
+ -------------
+ -- Present --
+ -------------
+
+ function Present (T : Instance) return Boolean is
+ begin
+ return T /= Nil;
+ end Present;
+
---------
-- Put --
---------
------------
procedure Expand is
- pragma Assert (T /= null);
- pragma Assert (T.Buckets /= null);
+ pragma Assert (Present (T));
+ pragma Assert (Present (T.Buckets));
Old_Size : constant Bucket_Range_Type := T.Buckets'Length;
------------------------
procedure Prepend_Or_Replace (Head : Node_Ptr) is
- pragma Assert (Head /= null);
+ pragma Assert (Present (Head));
Nod : Node_Ptr;
-- The following package offers a hash table abstraction with the following
-- characteristics:
--
- -- * Dynamic resizing based on load factor.
- -- * Creation of multiple instances, of different sizes.
- -- * Iterable keys.
+ -- * Dynamic resizing based on load factor
+ -- * Creation of multiple instances, of different sizes
+ -- * Iterable keys
--
-- This type of hash table is best used in scenarios where the size of the
-- key set is not known. The dynamic resizing aspect allows for performance
(Left : Key_Type;
Right : Key_Type) return Boolean;
+ with procedure Destroy_Value (Val : in out Value_Type);
+ -- Value destructor
+
with function Hash (Key : Key_Type) return Bucket_Range_Type;
-- Map an arbitrary key into the range of buckets
function Is_Empty (T : Instance) return Boolean;
-- Determine whether hash table T is empty
+ function Present (T : Instance) return Boolean;
+ -- Determine whether hash table T exists
+
procedure Put (T : Instance; Key : Key_Type; Value : Value_Type);
-- Associate value Value with key Key in hash table T. If the table
-- already contains a mapping of the same key to a previous value, the
type Iterator is private;
- function Iterate (T : Instance) return Iterator;
- -- Obtain an iterator over the keys of hash table T. This action locks
- -- all mutation functionality of the associated hash table.
-
function Has_Next (Iter : Iterator) return Boolean;
-- Determine whether iterator Iter has more keys to examine. If the
-- iterator has been exhausted, restore all mutation functionality of
-- the associated hash table.
+ function Iterate (T : Instance) return Iterator;
+ -- Obtain an iterator over the keys of hash table T. This action locks
+ -- all mutation functionality of the associated hash table.
+
procedure Next (Iter : in out Iterator; Key : out Key_Type);
-- Return the current key referenced by iterator Iter and advance to
-- the next available key. If the iterator has been exhausted and
-- The following type represents a key iterator
type Iterator is record
- Idx : Bucket_Range_Type := 0;
+ Curr_Idx : Bucket_Range_Type := 0;
-- Index of the current bucket being examined. This index is always
-- kept within the range of the buckets.
- Nod : Node_Ptr := null;
+ Curr_Nod : Node_Ptr := null;
-- Reference to the current node being examined within the current
-- bucket. The invariant of the iterator requires that this field
-- always point to a valid node. A value of null indicates that the
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- G N A T . G R A P H S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2018-2019, 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_Graph is
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ procedure Add_Component
+ (G : Instance;
+ Comp : Component_Id;
+ Vertices : Vertex_List.Instance);
+ pragma Inline (Add_Component);
+ -- Add component Comp which houses vertices Vertices to graph G
+
+ procedure Ensure_Created (G : Instance);
+ pragma Inline (Ensure_Created);
+ -- Verify that graph G is created. Raise Not_Created if this is not the
+ -- case.
+
+ procedure Ensure_Not_Present
+ (G : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ 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 (Graph, Instance);
+
+ function Get_Component_Attributes
+ (G : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ V : Vertex_Id) return Edge_Set.Instance;
+ pragma Inline (Get_Outgoing_Edges);
+ -- Obtain the Outgoing_Edges attribute of vertex V of graph G
+
+ function Get_Vertices
+ (G : Instance;
+ Comp : Component_Id) return Vertex_List.Instance;
+ pragma Inline (Get_Vertices);
+ -- Obtain the Vertices attribute of component Comp of graph G
+
+ procedure Set_Component
+ (G : Instance;
+ 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 : Instance;
+ V : Vertex_Id;
+ Val : Edge_Set.Instance);
+ pragma Inline (Set_Outgoing_Edges);
+ -- Set attribute Outgoing_Edges of vertex V of graph G to value Val
+
+ procedure Set_Vertex_Attributes
+ (G : Instance;
+ 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 : Instance;
+ Comp : Component_Id;
+ Vertices : Vertex_List.Instance)
+ 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 : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ Comp : Component_Id) return Boolean
+ is
+ begin
+ Ensure_Created (G);
+
+ return Get_Component_Attributes (G, Comp) /= No_Component_Attributes;
+ end Contains_Component;
+
+ -------------------
+ -- Contains_Edge --
+ -------------------
+
+ function Contains_Edge
+ (G : Instance;
+ E : Edge_Id) return Boolean
+ is
+ begin
+ Ensure_Created (G);
+
+ return Get_Edge_Attributes (G, E) /= No_Edge_Attributes;
+ end Contains_Edge;
+
+ ---------------------
+ -- Contains_Vertex --
+ ---------------------
+
+ function Contains_Vertex
+ (G : Instance;
+ V : Vertex_Id) return Boolean
+ is
+ begin
+ Ensure_Created (G);
+
+ return Get_Vertex_Attributes (G, V) /= No_Vertex_Attributes;
+ end Contains_Vertex;
+
+ ------------
+ -- Create --
+ ------------
+
+ function Create
+ (Initial_Vertices : Positive;
+ Initial_Edges : Positive) return Instance
+ is
+ G : constant Instance := new Graph;
+
+ 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 : Instance;
+ 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 : Instance;
+ 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 Instance) 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 : Instance) is
+ begin
+ if not Present (G) then
+ raise Not_Created;
+ end if;
+ end Ensure_Created;
+
+ ------------------------
+ -- Ensure_Not_Present --
+ ------------------------
+
+ procedure Ensure_Not_Present
+ (G : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ 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 : Instance) 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 library item appears in 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_HTable
+ (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_List
+ (Element_Type => Vertex_Id,
+ "=" => Same_Vertex,
+ Destroy_Element => Destroy_Vertex);
+
+ -----------------
+ -- Global data --
+ -----------------
+
+ Attrs : Tarjan_Map.Instance := Tarjan_Map.Nil;
+ Stack : Tarjan_Stack.Instance := 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 : Vertex_Iterator;
+ V : Vertex_Id;
+
+ begin
+ Iter := Iterate_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.Instance;
+
+ 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 : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ 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 : Instance;
+ V : Vertex_Id) return Edge_Set.Instance
+ 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 : Instance;
+ Comp : Component_Id) return Vertex_List.Instance
+ 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 : Outgoing_Edge_Iterator) return Boolean is
+ begin
+ return Edge_Set.Has_Next (Edge_Set.Iterator (Iter));
+ end Has_Next;
+
+ --------------
+ -- Has_Next --
+ --------------
+
+ function Has_Next (Iter : Vertex_Iterator) return Boolean is
+ begin
+ return Vertex_List.Has_Next (Vertex_List.Iterator (Iter));
+ end Has_Next;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (G : Instance) 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 : Instance) 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 : Instance) 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 : Instance) return Component_Iterator is
+ begin
+ Ensure_Created (G);
+
+ return Component_Iterator (Component_Map.Iterate (G.Components));
+ end Iterate_Components;
+
+ ----------------------------
+ -- Iterate_Outgoing_Edges --
+ ----------------------------
+
+ function Iterate_Outgoing_Edges
+ (G : Instance;
+ 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;
+
+ ----------------------
+ -- Iterate_Vertices --
+ ----------------------
+
+ function Iterate_Vertices
+ (G : Instance;
+ Comp : Component_Id) return Vertex_Iterator
+ is
+ begin
+ Ensure_Created (G);
+ Ensure_Present (G, Comp);
+
+ return Vertex_Iterator (Vertex_List.Iterate (Get_Vertices (G, Comp)));
+ end Iterate_Vertices;
+
+ ----------
+ -- 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 Outgoing_Edge_Iterator;
+ E : out Edge_Id)
+ is
+ begin
+ Edge_Set.Next (Edge_Set.Iterator (Iter), E);
+ end Next;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next
+ (Iter : in out Vertex_Iterator;
+ V : out Vertex_Id)
+ is
+ begin
+ Vertex_List.Next (Vertex_List.Iterator (Iter), V);
+ end Next;
+
+ --------------------------
+ -- Number_Of_Components --
+ --------------------------
+
+ function Number_Of_Components (G : Instance) 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 : Instance) return Natural is
+ begin
+ Ensure_Created (G);
+
+ return Edge_Map.Size (G.All_Edges);
+ end Number_Of_Edges;
+
+ ------------------------
+ -- Number_Of_Vertices --
+ ------------------------
+
+ function Number_Of_Vertices (G : Instance) return Natural is
+ begin
+ Ensure_Created (G);
+
+ return Vertex_Map.Size (G.All_Vertices);
+ end Number_Of_Vertices;
+
+ -------------
+ -- Present --
+ -------------
+
+ function Present (G : Instance) return Boolean is
+ begin
+ return G /= Nil;
+ end Present;
+
+ -------------------
+ -- Set_Component --
+ -------------------
+
+ procedure Set_Component
+ (G : Instance;
+ 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 : Instance;
+ V : Vertex_Id;
+ Val : Edge_Set.Instance)
+ 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 : Instance;
+ 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 : Instance;
+ 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_Graph;
+
+ --------------------
+ -- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- G N A T . G R A P H S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2018-2019, 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. --
+-- --
+------------------------------------------------------------------------------
+
+pragma Compiler_Unit_Warning;
+
+with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
+with GNAT.Lists; use GNAT.Lists;
+with GNAT.Sets; use GNAT.Sets;
+
+package GNAT.Graphs is
+
+ ---------------
+ -- Componant --
+ ---------------
+
+ -- The following type denotes a strongly connected component handle
+ -- (referred to as simply "component") in a graph.
+
+ type Component_Id is new Natural;
+ No_Component : constant Component_Id;
+
+ function Hash_Component (Comp : Component_Id) return Bucket_Range_Type;
+ -- Map component Comp into the range of buckets
+
+ function Present (Comp : Component_Id) return Boolean;
+ -- Determine whether component Comp exists
+
+ --------------------
+ -- Directed_Graph --
+ --------------------
+
+ -- The following package offers a directed graph abstraction with the
+ -- following characteristics:
+ --
+ -- * Dynamic resizing based on number of vertices and edges
+ -- * Creation of multiple instances, of different sizes
+ -- * Discovery of strongly connected components
+ -- * Iterable attributes
+ --
+ -- The following use pattern must be employed when operating this graph:
+ --
+ -- Graph : Instance := Create (<some size>, <some size>);
+ --
+ -- <various operations>
+ --
+ -- Destroy (Graph);
+ --
+ -- The destruction of the graph reclaims all storage occupied by it.
+
+ generic
+
+ --------------
+ -- Vertices --
+ --------------
+
+ type Vertex_Id is private;
+ -- The handle of a vertex
+
+ No_Vertex : Vertex_Id;
+ -- An indicator for a nonexistent vertex
+
+ with function Hash_Vertex (V : Vertex_Id) return Bucket_Range_Type;
+ -- Map vertex V into the range of buckets
+
+ with function Same_Vertex
+ (Left : Vertex_Id;
+ Right : Vertex_Id) return Boolean;
+ -- Compare vertex Left to vertex Right for identity
+
+ -----------
+ -- Edges --
+ -----------
+
+ type Edge_Id is private;
+ -- The handle of an edge
+
+ No_Edge : Edge_Id;
+ -- An indicator for a nonexistent edge
+
+ with function Hash_Edge (E : Edge_Id) return Bucket_Range_Type;
+ -- Map edge E into the range of buckets
+
+ with function Same_Edge
+ (Left : Edge_Id;
+ Right : Edge_Id) return Boolean;
+ -- Compare edge Left to edge Right for identity
+
+ package Directed_Graph is
+
+ -- The following exceptions are raised when an attempt is made to add
+ -- the same edge or vertex in a graph.
+
+ Duplicate_Edge : exception;
+ Duplicate_Vertex : exception;
+
+ -- The following exceptions are raised when an attempt is made to delete
+ -- or reference a nonexistent component, edge, or vertex in a graph.
+
+ Missing_Component : exception;
+ Missing_Edge : exception;
+ Missing_Vertex : exception;
+
+ ----------------------
+ -- Graph operations --
+ ----------------------
+
+ -- The following type denotes a graph handle. Each instance must be
+ -- created using routine Create.
+
+ type Instance is private;
+ Nil : constant Instance;
+
+ procedure Add_Edge
+ (G : Instance;
+ E : Edge_Id;
+ Source : Vertex_Id;
+ Destination : Vertex_Id);
+ -- Add edge E to graph G which links vertex source Source and desination
+ -- vertex Destination. The edge is "owned" by vertex Source. This action
+ -- raises the following exceptions:
+ --
+ -- * Duplicate_Edge, when the edge is already present in the graph
+ --
+ -- * Iterated, when the graph has an outstanding edge iterator
+ --
+ -- * Missing_Vertex, when either the source or desination are not
+ -- present in the graph.
+
+ procedure Add_Vertex
+ (G : Instance;
+ V : Vertex_Id);
+ -- Add vertex V to graph G. This action raises the following exceptions:
+ --
+ -- * Duplicate_Vertex, when the vertex is already present in the graph
+ --
+ -- * Iterated, when the graph has an outstanding vertex iterator
+
+ function Component
+ (G : Instance;
+ V : Vertex_Id) return Component_Id;
+ -- Obtain the component where vertex V of graph G resides. This action
+ -- raises the following exceptions:
+ --
+ -- * Missing_Vertex, when the vertex is not present in the graph
+
+ function Contains_Component
+ (G : Instance;
+ Comp : Component_Id) return Boolean;
+ -- Determine whether graph G contains component Comp
+
+ function Contains_Edge
+ (G : Instance;
+ E : Edge_Id) return Boolean;
+ -- Determine whether graph G contains edge E
+
+ function Contains_Vertex
+ (G : Instance;
+ V : Vertex_Id) return Boolean;
+ -- Determine whether graph G contains vertex V
+
+ function Create
+ (Initial_Vertices : Positive;
+ Initial_Edges : Positive) return Instance;
+ -- Create a new graph with vertex capacity Initial_Vertices and edge
+ -- capacity Initial_Edges. This routine must be called at the start of
+ -- a graph's lifetime.
+
+ procedure Delete_Edge
+ (G : Instance;
+ E : Edge_Id);
+ -- Delete edge E from graph G. This action raises these exceptions:
+ --
+ -- * Iterated, when the graph has an outstanding edge iterator
+ --
+ -- * Missing_Edge, when the edge is not present in the graph
+ --
+ -- * Missing_Vertex, when the source vertex that "owns" the edge is
+ -- not present in the graph.
+
+ function Destination_Vertex
+ (G : Instance;
+ E : Edge_Id) return Vertex_Id;
+ -- Obtain the destination vertex of edge E of graph G. This action
+ -- raises the following exceptions:
+ --
+ -- * Missing_Edge, when the edge is not present in the graph
+
+ procedure Destroy (G : in out Instance);
+ -- Destroy the contents of graph G, rendering it unusable. This routine
+ -- must be called at the end of a graph's lifetime. This action raises
+ -- the following exceptions:
+ --
+ -- * Iterated, if the graph has any outstanding iterator
+
+ procedure Find_Components (G : Instance);
+ -- Find all components of graph G. This action raises the following
+ -- exceptions:
+ --
+ -- * Iterated, when the components or vertices of the graph have an
+ -- outstanding iterator.
+
+ function Is_Empty (G : Instance) return Boolean;
+ -- Determine whether graph G is empty
+
+ function Number_Of_Components (G : Instance) return Natural;
+ -- Obtain the total number of components of graph G
+
+ function Number_Of_Edges (G : Instance) return Natural;
+ -- Obtain the total number of edges of graph G
+
+ function Number_Of_Vertices (G : Instance) return Natural;
+ -- Obtain the total number of vertices of graph G
+
+ function Present (G : Instance) return Boolean;
+ -- Determine whether graph G exists
+
+ function Source_Vertex
+ (G : Instance;
+ E : Edge_Id) return Vertex_Id;
+ -- Obtain the source vertex that "owns" edge E of graph G. This action
+ -- raises the following exceptions:
+ --
+ -- * Missing_Edge, when the edge is not present in the graph
+
+ -------------------------
+ -- Iterator operations --
+ -------------------------
+
+ -- The following types represent iterators over various attributes of a
+ -- graph. Each iterator locks all mutation operations of its associated
+ -- attribute, and unlocks them once it is exhausted. The iterators must
+ -- be used with the following pattern:
+ --
+ -- Iter : Iterate_XXX (Graph);
+ -- while Has_Next (Iter) loop
+ -- Next (Iter, Element);
+ -- end loop;
+ --
+ -- It is possible to advance the iterators by using Next only, however
+ -- this risks raising Iterator_Exhausted.
+
+ -- The following type represents an iterator over all edges of a graph
+
+ type All_Edge_Iterator is private;
+
+ function Has_Next (Iter : All_Edge_Iterator) return Boolean;
+ -- Determine whether iterator Iter has more edges to examine
+
+ function Iterate_All_Edges (G : Instance) return All_Edge_Iterator;
+ -- Obtain an iterator over all edges of graph G
+
+ procedure Next
+ (Iter : in out All_Edge_Iterator;
+ E : out Edge_Id);
+ -- Return the current edge referenced by iterator Iter and advance to
+ -- the next available edge. This action raises the following exceptions:
+ --
+ -- * Iterator_Exhausted, when the iterator has been exhausted and
+ -- further attempts are made to advance it.
+
+ -- The following type represents an iterator over all vertices of a
+ -- graph.
+
+ type All_Vertex_Iterator is private;
+
+ function Has_Next (Iter : All_Vertex_Iterator) return Boolean;
+ -- Determine whether iterator Iter has more vertices to examine
+
+ function Iterate_All_Vertices (G : Instance) return All_Vertex_Iterator;
+ -- Obtain an iterator over all vertices of graph G
+
+ procedure Next
+ (Iter : in out All_Vertex_Iterator;
+ V : out Vertex_Id);
+ -- Return the current vertex referenced by iterator Iter and advance
+ -- to the next available vertex. This action raises the following
+ -- exceptions:
+ --
+ -- * Iterator_Exhausted, when the iterator has been exhausted and
+ -- further attempts are made to advance it.
+
+ -- The following type represents an iterator over all components of a
+ -- graph.
+
+ type Component_Iterator is private;
+
+ function Has_Next (Iter : Component_Iterator) return Boolean;
+ -- Determine whether iterator Iter has more components to examine
+
+ function Iterate_Components (G : Instance) return Component_Iterator;
+ -- Obtain an iterator over all components of graph G
+
+ procedure Next
+ (Iter : in out Component_Iterator;
+ Comp : out Component_Id);
+ -- Return the current component referenced by iterator Iter and advance
+ -- to the next component. This action raises the following exceptions:
+ --
+ -- * Iterator_Exhausted, when the iterator has been exhausted and
+ -- further attempts are made to advance it.
+
+ -- The following type represents an iterator over all outgoing edges of
+ -- a vertex.
+
+ type Outgoing_Edge_Iterator is private;
+
+ function Has_Next (Iter : Outgoing_Edge_Iterator) return Boolean;
+ -- Determine whether iterator Iter has more outgoing edges to examine
+
+ function Iterate_Outgoing_Edges
+ (G : Instance;
+ V : Vertex_Id) return Outgoing_Edge_Iterator;
+ -- Obtain an iterator over all the outgoing edges "owned" by vertex V of
+ -- graph G.
+
+ procedure Next
+ (Iter : in out Outgoing_Edge_Iterator;
+ E : out Edge_Id);
+ -- Return the current outgoing edge referenced by iterator Iter and
+ -- advance to the next available outgoing edge. This action raises the
+ -- following exceptions:
+ --
+ -- * Iterator_Exhausted, when the iterator has been exhausted and
+ -- further attempts are made to advance it.
+
+ -- The following type prepresents an iterator over all vertices of a
+ -- component.
+
+ type Vertex_Iterator is private;
+
+ function Has_Next (Iter : Vertex_Iterator) return Boolean;
+ -- Determine whether iterator Iter has more vertices to examine
+
+ function Iterate_Vertices
+ (G : Instance;
+ Comp : Component_Id) return Vertex_Iterator;
+ -- Obtain an iterator over all vertices that comprise component Comp of
+ -- graph G.
+
+ procedure Next
+ (Iter : in out Vertex_Iterator;
+ V : out Vertex_Id);
+ -- Return the current vertex referenced by iterator Iter and advance to
+ -- the next vertex. This action raises the following exceptions:
+ --
+ -- * Iterator_Exhausted, when the iterator has been exhausted and
+ -- further attempts are made to advance it.
+
+ private
+ pragma Unreferenced (No_Edge);
+
+ --------------
+ -- Edge_Map --
+ --------------
+
+ type Edge_Attributes is record
+ Destination : Vertex_Id := No_Vertex;
+ -- The target of a directed edge
+
+ Source : Vertex_Id := No_Vertex;
+ -- The origin of a directed edge. The source vertex "owns" the edge.
+ end record;
+
+ No_Edge_Attributes : constant Edge_Attributes :=
+ (Destination => No_Vertex,
+ Source => No_Vertex);
+
+ procedure Destroy_Edge_Attributes (Attrs : in out Edge_Attributes);
+ -- Destroy the contents of attributes Attrs
+
+ package Edge_Map is new Dynamic_HTable
+ (Key_Type => Edge_Id,
+ Value_Type => Edge_Attributes,
+ No_Value => No_Edge_Attributes,
+ Expansion_Threshold => 1.5,
+ Expansion_Factor => 2,
+ Compression_Threshold => 0.3,
+ Compression_Factor => 2,
+ "=" => Same_Edge,
+ Destroy_Value => Destroy_Edge_Attributes,
+ Hash => Hash_Edge);
+
+ --------------
+ -- Edge_Set --
+ --------------
+
+ package Edge_Set is new Membership_Set
+ (Element_Type => Edge_Id,
+ "=" => "=",
+ Hash => Hash_Edge);
+
+ -----------------
+ -- Vertex_List --
+ -----------------
+
+ procedure Destroy_Vertex (V : in out Vertex_Id);
+ -- Destroy the contents of a vertex
+
+ package Vertex_List is new Doubly_Linked_List
+ (Element_Type => Vertex_Id,
+ "=" => Same_Vertex,
+ Destroy_Element => Destroy_Vertex);
+
+ ----------------
+ -- Vertex_Map --
+ ----------------
+
+ type Vertex_Attributes is record
+ Component : Component_Id := No_Component;
+ -- The component where a vertex lives
+
+ Outgoing_Edges : Edge_Set.Instance := Edge_Set.Nil;
+ -- The set of edges that extend out from a vertex
+ end record;
+
+ No_Vertex_Attributes : constant Vertex_Attributes :=
+ (Component => No_Component,
+ Outgoing_Edges => Edge_Set.Nil);
+
+ procedure Destroy_Vertex_Attributes (Attrs : in out Vertex_Attributes);
+ -- Destroy the contents of attributes Attrs
+
+ package Vertex_Map is new Dynamic_HTable
+ (Key_Type => Vertex_Id,
+ Value_Type => Vertex_Attributes,
+ No_Value => No_Vertex_Attributes,
+ Expansion_Threshold => 1.5,
+ Expansion_Factor => 2,
+ Compression_Threshold => 0.3,
+ Compression_Factor => 2,
+ "=" => Same_Vertex,
+ Destroy_Value => Destroy_Vertex_Attributes,
+ Hash => Hash_Vertex);
+
+ -------------------
+ -- Component_Map --
+ -------------------
+
+ type Component_Attributes is record
+ Vertices : Vertex_List.Instance := Vertex_List.Nil;
+ end record;
+
+ No_Component_Attributes : constant Component_Attributes :=
+ (Vertices => Vertex_List.Nil);
+
+ procedure Destroy_Component_Attributes
+ (Attrs : in out Component_Attributes);
+ -- Destroy the contents of attributes Attrs
+
+ package Component_Map is new Dynamic_HTable
+ (Key_Type => Component_Id,
+ Value_Type => Component_Attributes,
+ No_Value => No_Component_Attributes,
+ Expansion_Threshold => 1.5,
+ Expansion_Factor => 2,
+ Compression_Threshold => 0.3,
+ Compression_Factor => 2,
+ "=" => "=",
+ Destroy_Value => Destroy_Component_Attributes,
+ Hash => Hash_Component);
+
+ -----------
+ -- Graph --
+ -----------
+
+ type Graph is record
+ All_Edges : Edge_Map.Instance := Edge_Map.Nil;
+ -- The map of edge -> edge attributes for all edges in the graph
+
+ All_Vertices : Vertex_Map.Instance := Vertex_Map.Nil;
+ -- The map of vertex -> vertex attributes for all vertices in the
+ -- graph.
+
+ Components : Component_Map.Instance := Component_Map.Nil;
+ -- The map of component -> component attributes for all components
+ -- in the graph.
+ end record;
+
+ --------------
+ -- Instance --
+ --------------
+
+ type Instance is access Graph;
+ Nil : constant Instance := null;
+
+ ---------------
+ -- Iterators --
+ ---------------
+
+ type All_Edge_Iterator is new Edge_Map.Iterator;
+ type All_Vertex_Iterator is new Vertex_Map.Iterator;
+ type Component_Iterator is new Component_Map.Iterator;
+ type Outgoing_Edge_Iterator is new Edge_Set.Iterator;
+ type Vertex_Iterator is new Vertex_List.Iterator;
+ end Directed_Graph;
+
+private
+ No_Component : constant Component_Id := Component_Id'First;
+ First_Component : constant Component_Id := No_Component + 1;
+
+end GNAT.Graphs;
pragma Inline (Lock);
-- Lock all mutation functionality of list L
+ function Present (Nod : Node_Ptr) return Boolean;
+ pragma Inline (Present);
+ -- Determine whether node Nod exists
+
procedure Unlock (L : Instance);
pragma Inline (Unlock);
-- Unlock all mutation functionality of list L
procedure Delete_Node (L : Instance; Nod : Node_Ptr) is
Ref : Node_Ptr := Nod;
- pragma Assert (Ref /= null);
+ pragma Assert (Present (Ref));
Next : constant Node_Ptr := Ref.Next;
Prev : constant Node_Ptr := Ref.Prev;
begin
- pragma Assert (L /= null);
- pragma Assert (Next /= null);
- pragma Assert (Prev /= null);
+ pragma Assert (Present (L));
+ pragma Assert (Present (Next));
+ pragma Assert (Present (Prev));
Prev.Next := Next; -- Prev ---> Next
Next.Prev := Prev; -- Prev <--> Next
L.Elements := L.Elements - 1;
+ -- Invoke the element destructor before deallocating the node
+
+ Destroy_Element (Nod.Elem);
+
Free (Ref);
end Delete_Node;
---------------------
procedure Ensure_Circular (Head : Node_Ptr) is
- pragma Assert (Head /= null);
+ pragma Assert (Present (Head));
begin
- if Head.Next = null and then Head.Prev = null then
+ if not Present (Head.Next) and then not Present (Head.Prev) then
Head.Next := Head;
Head.Prev := Head;
end if;
procedure Ensure_Created (L : Instance) is
begin
- if L = null then
+ if not Present (L) then
raise Not_Created;
end if;
end Ensure_Created;
procedure Ensure_Full (L : Instance) is
begin
- pragma Assert (L /= null);
+ pragma Assert (Present (L));
if L.Elements = 0 then
raise List_Empty;
procedure Ensure_Unlocked (L : Instance) is
begin
- pragma Assert (L /= null);
+ pragma Assert (Present (L));
-- The list has at least one outstanding iterator
(Head : Node_Ptr;
Elem : Element_Type) return Node_Ptr
is
- pragma Assert (Head /= null);
+ pragma Assert (Present (Head));
Nod : Node_Ptr;
Left : Node_Ptr;
Right : Node_Ptr)
is
- pragma Assert (L /= null);
- pragma Assert (Left /= null);
- pragma Assert (Right /= null);
+ pragma Assert (Present (L));
+ pragma Assert (Present (Left));
+ pragma Assert (Present (Right));
Nod : constant Node_Ptr :=
new Node'(Elem => Elem,
-- The invariant of Iterate and Next ensures that the iterator always
-- refers to a valid node if there exists one.
- return Is_Valid (Iter.Nod, Iter.List.Nodes'Access);
+ return Is_Valid (Iter.Curr_Nod, Iter.List.Nodes'Access);
end Is_Valid;
--------------
-- A node is valid if it is non-null, and does not refer to the dummy
-- head of some list.
- return Nod /= null and then Nod /= Head;
+ return Present (Nod) and then Nod /= Head;
end Is_Valid;
-------------
Lock (L);
- return (List => L, Nod => L.Nodes.Next);
+ return (List => L, Curr_Nod => L.Nodes.Next);
end Iterate;
----------
procedure Lock (L : Instance) is
begin
- pragma Assert (L /= null);
+ pragma Assert (Present (L));
-- The list may be locked multiple times if multiple iterators are
-- operating over it.
procedure Next (Iter : in out Iterator; Elem : out Element_Type) is
Is_OK : constant Boolean := Is_Valid (Iter);
- Saved : constant Node_Ptr := Iter.Nod;
+ Saved : constant Node_Ptr := Iter.Curr_Nod;
begin
-- The iterator is no linger valid which indicates that it has been
-- Advance to the next node along the list
- Iter.Nod := Iter.Nod.Next;
- Elem := Saved.Elem;
+ Iter.Curr_Nod := Iter.Curr_Nod.Next;
+
+ Elem := Saved.Elem;
end Next;
-------------
Right => Head.Next);
end Prepend;
+ -------------
+ -- Present --
+ -------------
+
+ function Present (L : Instance) return Boolean is
+ begin
+ return L /= Nil;
+ end Present;
+
+ -------------
+ -- Present --
+ -------------
+
+ function Present (Nod : Node_Ptr) return Boolean is
+ begin
+ return Nod /= null;
+ end Present;
+
-------------
-- Replace --
-------------
procedure Unlock (L : Instance) is
begin
- pragma Assert (L /= null);
+ pragma Assert (Present (L));
-- The list may be locked multiple times if multiple iterators are
-- operating over it.
-- The following package offers a doubly linked list abstraction with the
-- following characteristics:
--
- -- * Creation of multiple instances, of different sizes.
- -- * Iterable elements.
+ -- * Creation of multiple instances, of different sizes
+ -- * Iterable elements
--
-- The following use pattern must be employed with this list:
--
(Left : Element_Type;
Right : Element_Type) return Boolean;
+ with procedure Destroy_Element (Elem : in out Element_Type);
+ -- Element destructor
+
package Doubly_Linked_List is
---------------------
-- Insert element Elem at the start of list L. This action will raise
-- Iterated if the list has outstanding iterators.
+ function Present (L : Instance) return Boolean;
+ -- Determine whether list L exists
+
procedure Replace
(L : Instance;
Old_Elem : Element_Type;
type Iterator is private;
- function Iterate (L : Instance) return Iterator;
- -- Obtain an iterator over the elements of list L. This action locks all
- -- mutation functionality of the associated list.
-
function Has_Next (Iter : Iterator) return Boolean;
-- Determine whether iterator Iter has more elements to examine. If the
-- iterator has been exhausted, restore all mutation functionality of
-- the associated list.
+ function Iterate (L : Instance) return Iterator;
+ -- Obtain an iterator over the elements of list L. This action locks all
+ -- mutation functionality of the associated list.
+
procedure Next (Iter : in out Iterator; Elem : out Element_Type);
-- Return the current element referenced by iterator Iter and advance
-- to the next available element. If the iterator has been exhausted
-- The following type represents an element iterator
type Iterator is record
- List : Instance := null;
- -- Reference to the associated list
-
- Nod : Node_Ptr := null;
+ Curr_Nod : Node_Ptr := null;
-- Reference to the current node being examined. The invariant of the
-- iterator requires that this field always points to a valid node. A
-- value of null indicates that the iterator is exhausted.
+
+ List : Instance := null;
+ -- Reference to the associated list
end record;
end Doubly_Linked_List;
-- Destroy --
-------------
+ procedure Destroy (B : in out Boolean) is
+ pragma Unreferenced (B);
+ begin
+ null;
+ end Destroy;
+
+ -------------
+ -- Destroy --
+ -------------
+
procedure Destroy (S : in out Instance) is
begin
Hashed_Set.Destroy (Hashed_Set.Instance (S));
Hashed_Set.Next (Hashed_Set.Iterator (Iter), Elem);
end Next;
+ -------------
+ -- Present --
+ -------------
+
+ function Present (S : Instance) return Boolean is
+ begin
+ return Hashed_Set.Present (Hashed_Set.Instance (S));
+ end Present;
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset (S : Instance) is
+ begin
+ Hashed_Set.Reset (Hashed_Set.Instance (S));
+ end Reset;
+
----------
-- Size --
----------
-- The following package offers a membership set abstraction with the
-- following characteristics:
--
- -- * Creation of multiple instances, of different sizes.
- -- * Iterable elements.
+ -- * Creation of multiple instances, of different sizes
+ -- * Iterable elements
--
-- The following use pattern must be employed with this set:
--
function Is_Empty (S : Instance) return Boolean;
-- Determine whether set S is empty
+ function Present (S : Instance) return Boolean;
+ -- Determine whether set S exists
+
+ procedure Reset (S : Instance);
+ -- Destroy the contents of membership set S, and reset it to its initial
+ -- created state. This action will raise Iterated if the membership set
+ -- has outstanding iterators.
+
function Size (S : Instance) return Natural;
-- Obtain the number of elements in membership set S
-- raises Iterator_Exhausted.
private
+ procedure Destroy (B : in out Boolean);
+ -- Destroy boolean B
+
package Hashed_Set is new Dynamic_HTable
(Key_Type => Element_Type,
Value_Type => Boolean,
Compression_Threshold => 0.3,
Compression_Factor => 2,
"=" => "=",
+ Destroy_Value => Destroy,
Hash => Hash);
type Instance is new Hashed_Set.Instance;
projects / thirdparty / gcc.git / commitdiff
