diff options
author | Hristian Kirtchev <kirtchev@adacore.com> | 2019-07-01 13:34:40 +0000 |
---|---|---|
committer | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2019-07-01 13:34:40 +0000 |
commit | 5a428808e775ed9f52d9ae738b366acdbd361c19 (patch) | |
tree | 4515e15e148c69b7c611e4bc92607be829955126 /gcc | |
parent | 7c46e926fa592e2df23d260791cde72162bfc10c (diff) | |
download | gcc-5a428808e775ed9f52d9ae738b366acdbd361c19.zip gcc-5a428808e775ed9f52d9ae738b366acdbd361c19.tar.gz gcc-5a428808e775ed9f52d9ae738b366acdbd361c19.tar.bz2 |
[Ada] Implement GNAT.Graphs
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.
From-SVN: r272857
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/ChangeLog | 24 | ||||
-rw-r--r-- | gcc/ada/Makefile.rtl | 1 | ||||
-rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 1 | ||||
-rw-r--r-- | gcc/ada/impunit.adb | 1 | ||||
-rw-r--r-- | gcc/ada/libgnat/g-dynhta.adb | 199 | ||||
-rw-r--r-- | gcc/ada/libgnat/g-dynhta.ads | 24 | ||||
-rw-r--r-- | gcc/ada/libgnat/g-graphs.adb | 1453 | ||||
-rw-r--r-- | gcc/ada/libgnat/g-graphs.ads | 529 | ||||
-rw-r--r-- | gcc/ada/libgnat/g-lists.adb | 69 | ||||
-rw-r--r-- | gcc/ada/libgnat/g-lists.ads | 26 | ||||
-rw-r--r-- | gcc/ada/libgnat/g-sets.adb | 28 | ||||
-rw-r--r-- | gcc/ada/libgnat/g-sets.ads | 16 |
12 files changed, 2258 insertions, 113 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1d353e8..31fecb6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +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 diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 775ab98..916ae3e 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -421,6 +421,7 @@ GNATRTL_NONTASKING_OBJS= \ g-exptty$(objext) \ g-flocon$(objext) \ g-forstr$(objext) \ + g-graphs$(objext) \ g-heasor$(objext) \ g-hesora$(objext) \ g-hesorg$(objext) \ diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index de23b14..104b214 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -317,6 +317,7 @@ GNAT_ADA_OBJS = \ 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 \ diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 4ee99e6..80857b3 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -275,6 +275,7 @@ package body Impunit is ("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 diff --git a/gcc/ada/libgnat/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb index c47f6ff..31b77de 100644 --- a/gcc/ada/libgnat/g-dynhta.adb +++ b/gcc/ada/libgnat/g-dynhta.adb @@ -382,6 +382,10 @@ package body GNAT.Dynamic_HTables is -- 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 @@ -464,6 +468,14 @@ package body GNAT.Dynamic_HTables is 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 @@ -492,6 +504,34 @@ package body GNAT.Dynamic_HTables is ------------ 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, @@ -502,8 +542,8 @@ package body GNAT.Dynamic_HTables is -------------- 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; @@ -520,41 +560,27 @@ package body GNAT.Dynamic_HTables is -- 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 -- @@ -594,6 +620,10 @@ package body GNAT.Dynamic_HTables is 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; @@ -602,7 +632,7 @@ package body GNAT.Dynamic_HTables is -- 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); @@ -614,17 +644,17 @@ package body GNAT.Dynamic_HTables is ------------ 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; @@ -635,10 +665,10 @@ package body GNAT.Dynamic_HTables is --------------------- 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; @@ -650,7 +680,7 @@ package body GNAT.Dynamic_HTables is procedure Ensure_Created (T : Instance) is begin - if T = null then + if not Present (T) then raise Not_Created; end if; end Ensure_Created; @@ -661,7 +691,7 @@ package body GNAT.Dynamic_HTables is procedure Ensure_Unlocked (T : Instance) is begin - pragma Assert (T /= null); + pragma Assert (Present (T)); -- The hash table has at least one outstanding iterator @@ -678,7 +708,7 @@ package body GNAT.Dynamic_HTables is (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; @@ -691,7 +721,7 @@ package body GNAT.Dynamic_HTables is --------------- function Find_Node (Head : Node_Ptr; Key : Key_Type) return Node_Ptr is - pragma Assert (Head /= null); + pragma Assert (Present (Head)); Nod : Node_Ptr; @@ -725,8 +755,8 @@ package body GNAT.Dynamic_HTables is 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 @@ -788,7 +818,7 @@ package body GNAT.Dynamic_HTables is 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 @@ -821,7 +851,7 @@ package body GNAT.Dynamic_HTables is -- 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; -------------- @@ -833,7 +863,7 @@ package body GNAT.Dynamic_HTables is -- 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; ------------- @@ -845,7 +875,7 @@ package body GNAT.Dynamic_HTables is 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, @@ -856,8 +886,8 @@ package body GNAT.Dynamic_HTables is (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. @@ -877,8 +907,8 @@ package body GNAT.Dynamic_HTables is ----------------- 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 @@ -922,8 +952,8 @@ package body GNAT.Dynamic_HTables is 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); @@ -935,7 +965,7 @@ package body GNAT.Dynamic_HTables is ------------------- procedure Rehash_Bucket (Head : Node_Ptr; To : Bucket_Table_Ptr) is - pragma Assert (Head /= null); + pragma Assert (Present (Head)); Nod : Node_Ptr; @@ -955,7 +985,7 @@ package body GNAT.Dynamic_HTables is ----------------- procedure Rehash_Node (Nod : Node_Ptr; To : Bucket_Table_Ptr) is - pragma Assert (Nod /= null); + pragma Assert (Present (Nod)); Head : Node_Ptr; @@ -982,7 +1012,7 @@ package body GNAT.Dynamic_HTables is -- 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); @@ -1000,13 +1030,13 @@ package body GNAT.Dynamic_HTables is 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 @@ -1019,21 +1049,21 @@ package body GNAT.Dynamic_HTables is -- 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; @@ -1044,8 +1074,8 @@ package body GNAT.Dynamic_HTables is ------------- 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; @@ -1057,6 +1087,33 @@ package body GNAT.Dynamic_HTables is 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 -- --------- @@ -1078,8 +1135,8 @@ package body GNAT.Dynamic_HTables is ------------ 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; @@ -1099,7 +1156,7 @@ package body GNAT.Dynamic_HTables is ------------------------ procedure Prepend_Or_Replace (Head : Node_Ptr) is - pragma Assert (Head /= null); + pragma Assert (Present (Head)); Nod : Node_Ptr; diff --git a/gcc/ada/libgnat/g-dynhta.ads b/gcc/ada/libgnat/g-dynhta.ads index 0f81d72..7b8d1d8 100644 --- a/gcc/ada/libgnat/g-dynhta.ads +++ b/gcc/ada/libgnat/g-dynhta.ads @@ -265,9 +265,9 @@ package GNAT.Dynamic_HTables is -- 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 @@ -327,6 +327,9 @@ package GNAT.Dynamic_HTables is (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 @@ -366,6 +369,9 @@ package GNAT.Dynamic_HTables is 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 @@ -401,15 +407,15 @@ package GNAT.Dynamic_HTables is 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 @@ -475,11 +481,11 @@ package GNAT.Dynamic_HTables is -- 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 diff --git a/gcc/ada/libgnat/g-graphs.adb b/gcc/ada/libgnat/g-graphs.adb new file mode 100644 index 0000000..a763efb --- /dev/null +++ b/gcc/ada/libgnat/g-graphs.adb @@ -0,0 +1,1453 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/libgnat/g-graphs.ads b/gcc/ada/libgnat/g-graphs.ads new file mode 100644 index 0000000..7926a1b --- /dev/null +++ b/gcc/ada/libgnat/g-graphs.ads @@ -0,0 +1,529 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/libgnat/g-lists.adb b/gcc/ada/libgnat/g-lists.adb index 7cf7aa6..d1a8616 100644 --- a/gcc/ada/libgnat/g-lists.adb +++ b/gcc/ada/libgnat/g-lists.adb @@ -90,6 +90,10 @@ package body GNAT.Lists is 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 @@ -217,15 +221,15 @@ package body GNAT.Lists is 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 @@ -235,6 +239,10 @@ package body GNAT.Lists is L.Elements := L.Elements - 1; + -- Invoke the element destructor before deallocating the node + + Destroy_Element (Nod.Elem); + Free (Ref); end Delete_Node; @@ -263,10 +271,10 @@ package body GNAT.Lists is --------------------- 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; @@ -278,7 +286,7 @@ package body GNAT.Lists is procedure Ensure_Created (L : Instance) is begin - if L = null then + if not Present (L) then raise Not_Created; end if; end Ensure_Created; @@ -289,7 +297,7 @@ package body GNAT.Lists is procedure Ensure_Full (L : Instance) is begin - pragma Assert (L /= null); + pragma Assert (Present (L)); if L.Elements = 0 then raise List_Empty; @@ -302,7 +310,7 @@ package body GNAT.Lists is procedure Ensure_Unlocked (L : Instance) is begin - pragma Assert (L /= null); + pragma Assert (Present (L)); -- The list has at least one outstanding iterator @@ -319,7 +327,7 @@ package body GNAT.Lists is (Head : Node_Ptr; Elem : Element_Type) return Node_Ptr is - pragma Assert (Head /= null); + pragma Assert (Present (Head)); Nod : Node_Ptr; @@ -435,9 +443,9 @@ package body GNAT.Lists is 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, @@ -471,7 +479,7 @@ package body GNAT.Lists is -- 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; -------------- @@ -483,7 +491,7 @@ package body GNAT.Lists is -- 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; ------------- @@ -499,7 +507,7 @@ package body GNAT.Lists is Lock (L); - return (List => L, Nod => L.Nodes.Next); + return (List => L, Curr_Nod => L.Nodes.Next); end Iterate; ---------- @@ -520,7 +528,7 @@ package body GNAT.Lists is 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. @@ -534,7 +542,7 @@ package body GNAT.Lists is 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 @@ -548,8 +556,9 @@ package body GNAT.Lists is -- 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; ------------- @@ -580,6 +589,24 @@ package body GNAT.Lists is 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 -- ------------- @@ -620,7 +647,7 @@ package body GNAT.Lists is 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. diff --git a/gcc/ada/libgnat/g-lists.ads b/gcc/ada/libgnat/g-lists.ads index 75dfeb5..911b85f 100644 --- a/gcc/ada/libgnat/g-lists.ads +++ b/gcc/ada/libgnat/g-lists.ads @@ -40,8 +40,8 @@ package GNAT.Lists is -- 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: -- @@ -60,6 +60,9 @@ package GNAT.Lists is (Left : Element_Type; Right : Element_Type) return Boolean; + with procedure Destroy_Element (Elem : in out Element_Type); + -- Element destructor + package Doubly_Linked_List is --------------------- @@ -139,6 +142,9 @@ package GNAT.Lists 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; @@ -168,15 +174,15 @@ package GNAT.Lists is 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 @@ -215,13 +221,13 @@ package GNAT.Lists is -- 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; diff --git a/gcc/ada/libgnat/g-sets.adb b/gcc/ada/libgnat/g-sets.adb index bd367cb..f9e9213 100644 --- a/gcc/ada/libgnat/g-sets.adb +++ b/gcc/ada/libgnat/g-sets.adb @@ -68,6 +68,16 @@ package body GNAT.Sets is -- 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)); @@ -118,6 +128,24 @@ package body GNAT.Sets is 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 -- ---------- diff --git a/gcc/ada/libgnat/g-sets.ads b/gcc/ada/libgnat/g-sets.ads index 27b1a65..43610af 100644 --- a/gcc/ada/libgnat/g-sets.ads +++ b/gcc/ada/libgnat/g-sets.ads @@ -42,8 +42,8 @@ package GNAT.Sets is -- 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: -- @@ -103,6 +103,14 @@ package GNAT.Sets is 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 @@ -141,6 +149,9 @@ package GNAT.Sets is -- 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, @@ -150,6 +161,7 @@ package GNAT.Sets is Compression_Threshold => 0.3, Compression_Factor => 2, "=" => "=", + Destroy_Value => Destroy, Hash => Hash); type Instance is new Hashed_Set.Instance; |