Hristian Kirtchev [Mon, 1 Jul 2019 13:35:15 +0000 (13:35 +0000)]
[Ada] Clean up of GNAT.Graphs
------------
-- 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_Sets
(Element_Type => Edge_Id,
"=" => "=",
Hash => Hash_Edge);
package DG is new Directed_Graphs
(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_Sets
(Element_Type => Vertex_Id,
"=" => "=",
Hash => Hash_Vertex);
-----------------------
-- Local subprograms --
-----------------------
procedure Check_Belongs_To_Component
(R : String;
G : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
E : Edge_Id);
-- Verify that graph G contains edge E. R is the calling routine.
procedure Check_Has_Vertex
(R : String;
G : Directed_Graph;
V : Vertex_Id);
-- Verify that graph G contains vertex V. R is the calling routine.
procedure Check_No_Component
(R : String;
G : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
E : Edge_Id);
-- Verify that graph G does not contain edge E. R is the calling routine.
procedure Check_No_Vertex
(R : String;
G : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
V : Vertex_Id;
Set : ES.Membership_Set);
-- 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 : Directed_Graph;
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 : Directed_Graph;
Comp : Component_Id;
Set : VS.Membership_Set);
-- 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 Directed_Graph;
-- 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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
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 : Directed_Graph;
V : Vertex_Id;
Set : ES.Membership_Set)
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 : Directed_Graph;
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 : Directed_Graph;
Comp : Component_Id;
Set : VS.Membership_Set)
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 Directed_Graph is
G : constant Directed_Graph :=
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 : Directed_Graph := 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 : Directed_Graph := 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 : Directed_Graph := Create_And_Populate;
All_E_Iter : All_Edge_Iterator;
All_Edges : ES.Membership_Set;
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 : Directed_Graph := Create_And_Populate;
V : Vertex_Id;
All_V_Iter : All_Vertex_Iterator;
All_Vertices : VS.Membership_Set;
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 : Directed_Graph := 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 : Directed_Graph := 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 : Directed_Graph :=
Create (Initial_Vertices => 2, Initial_Edges => 2);
G2 : Directed_Graph :=
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 : Directed_Graph := 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 : Directed_Graph := 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 : Directed_Graph := 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 : Directed_Graph := 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 : Directed_Graph := 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 : Directed_Graph := 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 : Directed_Graph := 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 : Directed_Graph := 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 : Directed_Graph :=
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 : Directed_Graph := Create_And_Populate;
Set : ES.Membership_Set;
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 : Directed_Graph := 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 : Directed_Graph := 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 : Directed_Graph := Create_And_Populate;
Set : VS.Membership_Set;
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/
* libgnat/g-graphs.adb: Use type Directed_Graph rather than
Instance in various routines.
* libgnat/g-graphs.ads: Change type Instance to Directed_Graph.
Update various routines that mention the type.
From-SVN: r272863
Hristian Kirtchev [Mon, 1 Jul 2019 13:35:07 +0000 (13:35 +0000)]
[Ada] Clean up of GNAT.Sets
------------
-- Source --
------------
-- operations.adb
with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT;
with GNAT.Sets; use GNAT.Sets;
procedure Operations is
function Hash (Key : Integer) return Bucket_Range_Type;
package Integer_Sets is new Membership_Sets
(Element_Type => Integer,
"=" => "=",
Hash => Hash);
use Integer_Sets;
procedure Check_Empty
(Caller : String;
S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer);
-- Ensure that none of the elements in the range Low_Elem .. High_Elem are
-- present in set S, and that the set's length is 0.
procedure Check_Locked_Mutations
(Caller : String;
S : in out Membership_Set);
-- Ensure that all mutation operations of set S are locked
procedure Check_Present
(Caller : String;
S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer);
-- Ensure that all elements in the range Low_Elem .. High_Elem are present
-- in set S.
procedure Check_Unlocked_Mutations
(Caller : String;
S : in out Membership_Set);
-- Ensure that all mutation operations of set S are unlocked
procedure Populate
(S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer);
-- Add elements in the range Low_Elem .. High_Elem in set S
procedure Test_Contains
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive);
-- Verify that Contains properly identifies that elements in the range
-- Low_Elem .. High_Elem are within a set. Init_Size denotes the initial
-- size of the set.
procedure Test_Create;
-- Verify that all set operations fail on a non-created set
procedure Test_Delete
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive);
-- Verify that Delete properly removes elements in the range Low_Elem ..
-- High_Elem from a set. Init_Size denotes the initial size of the set.
procedure Test_Is_Empty;
-- Verify that Is_Empty properly returns this status of a set
procedure Test_Iterate;
-- Verify that iterators properly manipulate mutation operations
procedure Test_Iterate_Empty;
-- Verify that iterators properly manipulate mutation operations of an
-- empty set.
procedure Test_Iterate_Forced
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive);
-- Verify that an iterator that is forcefully advanced by Next properly
-- unlocks the mutation operations of a set. Init_Size denotes the initial
-- size of the set.
procedure Test_Size;
-- Verify that Size returns the correct size of a set
-----------------
-- Check_Empty --
-----------------
procedure Check_Empty
(Caller : String;
S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer)
is
Siz : constant Natural := Size (S);
begin
for Elem in Low_Elem .. High_Elem loop
if Contains (S, Elem) then
Put_Line ("ERROR: " & Caller & ": extra element" & Elem'Img);
end if;
end loop;
if Siz /= 0 then
Put_Line ("ERROR: " & Caller & ": wrong size");
Put_Line ("expected: 0");
Put_Line ("got :" & Siz'Img);
end if;
end Check_Empty;
----------------------------
-- Check_Locked_Mutations --
----------------------------
procedure Check_Locked_Mutations
(Caller : String;
S : in out Membership_Set)
is
begin
begin
Delete (S, 1);
Put_Line ("ERROR: " & Caller & ": Delete: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
end;
begin
Destroy (S);
Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception");
end;
begin
Insert (S, 1);
Put_Line ("ERROR: " & Caller & ": Insert: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Insert: unexpected exception");
end;
end Check_Locked_Mutations;
-------------------
-- Check_Present --
-------------------
procedure Check_Present
(Caller : String;
S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer)
is
Elem : Integer;
Iter : Iterator;
begin
Iter := Iterate (S);
for Exp_Elem in Low_Elem .. High_Elem loop
Next (Iter, Elem);
if Elem /= Exp_Elem then
Put_Line ("ERROR: " & Caller & ": Check_Present: wrong element");
Put_Line ("expected:" & Exp_Elem'Img);
Put_Line ("got :" & Elem'Img);
end if;
end loop;
-- At this point all elements should have been accounted for. Check for
-- extra elements.
while Has_Next (Iter) loop
Next (Iter, Elem);
Put_Line
("ERROR: " & Caller & ": Check_Present: extra element" & Elem'Img);
end loop;
exception
when Iterator_Exhausted =>
Put_Line
("ERROR: "
& Caller
& "Check_Present: incorrect number of elements");
end Check_Present;
------------------------------
-- Check_Unlocked_Mutations --
------------------------------
procedure Check_Unlocked_Mutations
(Caller : String;
S : in out Membership_Set)
is
begin
Delete (S, 1);
Insert (S, 1);
end Check_Unlocked_Mutations;
----------
-- Hash --
----------
function Hash (Key : Integer) return Bucket_Range_Type is
begin
return Bucket_Range_Type (Key);
end Hash;
--------------
-- Populate --
--------------
procedure Populate
(S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer)
is
begin
for Elem in Low_Elem .. High_Elem loop
Insert (S, Elem);
end loop;
end Populate;
-------------------
-- Test_Contains --
-------------------
procedure Test_Contains
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive)
is
Low_Bogus : constant Integer := Low_Elem - 1;
High_Bogus : constant Integer := High_Elem + 1;
S : Membership_Set := Create (Init_Size);
begin
Populate (S, Low_Elem, High_Elem);
-- Ensure that the elements are contained in the set
for Elem in Low_Elem .. High_Elem loop
if not Contains (S, Elem) then
Put_Line
("ERROR: Test_Contains: element" & Elem'Img & " not in set");
end if;
end loop;
-- Ensure that arbitrary elements which were not inserted in the set are
-- not contained in the set.
if Contains (S, Low_Bogus) then
Put_Line
("ERROR: Test_Contains: element" & Low_Bogus'Img & " in set");
end if;
if Contains (S, High_Bogus) then
Put_Line
("ERROR: Test_Contains: element" & High_Bogus'Img & " in set");
end if;
Destroy (S);
end Test_Contains;
-----------------
-- Test_Create --
-----------------
procedure Test_Create is
Count : Natural;
Flag : Boolean;
Iter : Iterator;
S : Membership_Set;
begin
-- Ensure that every routine defined in the API fails on a set which
-- has not been created yet.
begin
Flag := Contains (S, 1);
Put_Line ("ERROR: Test_Create: Contains: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Contains: unexpected exception");
end;
begin
Delete (S, 1);
Put_Line ("ERROR: Test_Create: Delete: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Delete: unexpected exception");
end;
begin
Insert (S, 1);
Put_Line ("ERROR: Test_Create: Insert: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Insert: unexpected exception");
end;
begin
Flag := Is_Empty (S);
Put_Line ("ERROR: Test_Create: Is_Empty: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Is_Empty: unexpected exception");
end;
begin
Iter := Iterate (S);
Put_Line ("ERROR: Test_Create: Iterate: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Iterate: unexpected exception");
end;
begin
Count := Size (S);
Put_Line ("ERROR: Test_Create: Size: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Size: unexpected exception");
end;
end Test_Create;
-----------------
-- Test_Delete --
-----------------
procedure Test_Delete
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive)
is
Iter : Iterator;
S : Membership_Set := Create (Init_Size);
begin
Populate (S, Low_Elem, High_Elem);
-- Delete all even elements
for Elem in Low_Elem .. High_Elem loop
if Elem mod 2 = 0 then
Delete (S, Elem);
end if;
end loop;
-- Ensure that all remaining odd elements are present in the set
for Elem in Low_Elem .. High_Elem loop
if Elem mod 2 /= 0 and then not Contains (S, Elem) then
Put_Line ("ERROR: Test_Delete: missing element" & Elem'Img);
end if;
end loop;
-- Delete all odd elements
for Elem in Low_Elem .. High_Elem loop
if Elem mod 2 /= 0 then
Delete (S, Elem);
end if;
end loop;
-- At this point the set should be completely empty
Check_Empty
(Caller => "Test_Delete",
S => S,
Low_Elem => Low_Elem,
High_Elem => High_Elem);
Destroy (S);
end Test_Delete;
-------------------
-- Test_Is_Empty --
-------------------
procedure Test_Is_Empty is
S : Membership_Set := Create (8);
begin
if not Is_Empty (S) then
Put_Line ("ERROR: Test_Is_Empty: set is not empty");
end if;
Insert (S, 1);
if Is_Empty (S) then
Put_Line ("ERROR: Test_Is_Empty: set is empty");
end if;
Delete (S, 1);
if not Is_Empty (S) then
Put_Line ("ERROR: Test_Is_Empty: set is not empty");
end if;
Destroy (S);
end Test_Is_Empty;
------------------
-- Test_Iterate --
------------------
procedure Test_Iterate is
Elem : Integer;
Iter_1 : Iterator;
Iter_2 : Iterator;
S : Membership_Set := Create (5);
begin
Populate (S, 1, 5);
-- Obtain an iterator. This action must lock all mutation operations of
-- the set.
Iter_1 := Iterate (S);
-- Ensure that every mutation routine defined in the API fails on a set
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate",
S => S);
-- Obtain another iterator
Iter_2 := Iterate (S);
-- Ensure that every mutation is still locked
Check_Locked_Mutations
(Caller => "Test_Iterate",
S => S);
-- Exhaust the first itertor
while Has_Next (Iter_1) loop
Next (Iter_1, Elem);
end loop;
-- Ensure that every mutation is still locked
Check_Locked_Mutations
(Caller => "Test_Iterate",
S => S);
-- Exhaust the second itertor
while Has_Next (Iter_2) loop
Next (Iter_2, Elem);
end loop;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate",
S => S);
Destroy (S);
end Test_Iterate;
------------------------
-- Test_Iterate_Empty --
------------------------
procedure Test_Iterate_Empty is
Elem : Integer;
Iter : Iterator;
S : Membership_Set := Create (5);
begin
-- Obtain an iterator. This action must lock all mutation operations of
-- the set.
Iter := Iterate (S);
-- Ensure that every mutation routine defined in the API fails on a set
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Empty",
S => S);
-- Attempt to iterate over the elements
while Has_Next (Iter) loop
Next (Iter, Elem);
Put_Line
("ERROR: Test_Iterate_Empty: element" & Elem'Img & " exists");
end loop;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate_Empty",
S => S);
Destroy (S);
end Test_Iterate_Empty;
-------------------------
-- Test_Iterate_Forced --
-------------------------
procedure Test_Iterate_Forced
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive)
is
Elem : Integer;
Iter : Iterator;
S : Membership_Set := Create (Init_Size);
begin
Populate (S, Low_Elem, High_Elem);
-- Obtain an iterator. This action must lock all mutation operations of
-- the set.
Iter := Iterate (S);
-- Ensure that every mutation routine defined in the API fails on a set
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Forced",
S => S);
-- Forcibly advance the iterator until it raises an exception
begin
for Guard in Low_Elem .. High_Elem + 1 loop
Next (Iter, Elem);
end loop;
Put_Line
("ERROR: Test_Iterate_Forced: Iterator_Exhausted not raised");
exception
when Iterator_Exhausted =>
null;
when others =>
Put_Line ("ERROR: Test_Iterate_Forced: unexpected exception");
end;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate_Forced",
S => S);
Destroy (S);
end Test_Iterate_Forced;
---------------
-- Test_Size --
---------------
procedure Test_Size is
S : Membership_Set := Create (6);
Siz : Natural;
begin
Siz := Size (S);
if Siz /= 0 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 0");
Put_Line ("got :" & Siz'Img);
end if;
Populate (S, 1, 2);
Siz := Size (S);
if Siz /= 2 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 2");
Put_Line ("got :" & Siz'Img);
end if;
Populate (S, 3, 6);
Siz := Size (S);
if Siz /= 6 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 6");
Put_Line ("got :" & Siz'Img);
end if;
Destroy (S);
end Test_Size;
-- Start of processing for Operations
begin
Test_Contains
(Low_Elem => 1,
High_Elem => 5,
Init_Size => 5);
Test_Create;
Test_Delete
(Low_Elem => 1,
High_Elem => 10,
Init_Size => 10);
Test_Is_Empty;
Test_Iterate;
Test_Iterate_Empty;
Test_Iterate_Forced
(Low_Elem => 1,
High_Elem => 5,
Init_Size => 5);
Test_Size;
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/
* libgnat/g-sets.adb: Use type Membership_Set rathern than
Instance in various routines.
* libgnat/g-sets.ads: Change type Instance to Membership_Set.
Update various routines that mention the type.
gcc/testsuite/
* gnat.dg/sets1.adb: Update.
From-SVN: r272862
Hristian Kirtchev [Mon, 1 Jul 2019 13:35:01 +0000 (13:35 +0000)]
[Ada] Clean up of GNAT.Lists
------------
-- Source --
------------
-- operations.adb
with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT;
with GNAT.Lists; use GNAT.Lists;
procedure Operations is
procedure Destroy (Val : in out Integer) is null;
package Integer_Lists is new Doubly_Linked_Lists
(Element_Type => Integer,
"=" => "=",
Destroy_Element => Destroy);
use Integer_Lists;
procedure Check_Empty
(Caller : String;
L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer);
-- Ensure that none of the elements in the range Low_Elem .. High_Elem are
-- present in list L, and that the list's length is 0.
procedure Check_Locked_Mutations
(Caller : String;
L : in out Doubly_Linked_List);
-- Ensure that all mutation operations of list L are locked
procedure Check_Present
(Caller : String;
L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer);
-- Ensure that all elements in the range Low_Elem .. High_Elem are present
-- in list L.
procedure Check_Unlocked_Mutations
(Caller : String;
L : in out Doubly_Linked_List);
-- Ensure that all mutation operations of list L are unlocked
procedure Populate_With_Append
(L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer);
-- Add elements in the range Low_Elem .. High_Elem in that order in list L
procedure Test_Append;
-- Verify that Append properly inserts at the tail of a list
procedure Test_Contains
(Low_Elem : Integer;
High_Elem : Integer);
-- Verify that Contains properly identifies that elements in the range
-- Low_Elem .. High_Elem are within a list.
procedure Test_Create;
-- Verify that all list operations fail on a non-created list
procedure Test_Delete
(Low_Elem : Integer;
High_Elem : Integer);
-- Verify that Delete properly removes elements in the range Low_Elem ..
-- High_Elem from a list.
procedure Test_Delete_First
(Low_Elem : Integer;
High_Elem : Integer);
-- Verify that Delete properly removes elements in the range Low_Elem ..
-- High_Elem from the head of a list.
procedure Test_Delete_Last
(Low_Elem : Integer;
High_Elem : Integer);
-- Verify that Delete properly removes elements in the range Low_Elem ..
-- High_Elem from the tail of a list.
procedure Test_First;
-- Verify that First properly returns the head of a list
procedure Test_Insert_After;
-- Verify that Insert_After properly adds an element after some other
-- element.
procedure Test_Insert_Before;
-- Vefity that Insert_Before properly adds an element before some other
-- element.
procedure Test_Is_Empty;
-- Verify that Is_Empty properly returns this status of a list
procedure Test_Iterate;
-- Verify that iterators properly manipulate mutation operations
procedure Test_Iterate_Empty;
-- Verify that iterators properly manipulate mutation operations of an
-- empty list.
procedure Test_Iterate_Forced
(Low_Elem : Integer;
High_Elem : Integer);
-- Verify that an iterator that is forcefully advanced by Next properly
-- unlocks the mutation operations of a list.
procedure Test_Last;
-- Verify that Last properly returns the tail of a list
procedure Test_Prepend;
-- Verify that Prepend properly inserts at the head of a list
procedure Test_Present;
-- Verify that Present properly detects a list
procedure Test_Replace;
-- Verify that Replace properly substitutes old elements with new ones
procedure Test_Size;
-- Verify that Size returns the correct size of a list
-----------------
-- Check_Empty --
-----------------
procedure Check_Empty
(Caller : String;
L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer)
is
Len : constant Natural := Size (L);
begin
for Elem in Low_Elem .. High_Elem loop
if Contains (L, Elem) then
Put_Line ("ERROR: " & Caller & ": extra element" & Elem'Img);
end if;
end loop;
if Len /= 0 then
Put_Line ("ERROR: " & Caller & ": wrong length");
Put_Line ("expected: 0");
Put_Line ("got :" & Len'Img);
end if;
end Check_Empty;
----------------------------
-- Check_Locked_Mutations --
----------------------------
procedure Check_Locked_Mutations
(Caller : String;
L : in out Doubly_Linked_List)
is
begin
begin
Append (L, 1);
Put_Line ("ERROR: " & Caller & ": Append: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Append: unexpected exception");
end;
begin
Delete (L, 1);
Put_Line ("ERROR: " & Caller & ": Delete: no exception raised");
exception
when List_Empty =>
null;
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
end;
begin
Delete_First (L);
Put_Line ("ERROR: " & Caller & ": Delete_First: no exception raised");
exception
when List_Empty =>
null;
when Iterated =>
null;
when others =>
Put_Line
("ERROR: " & Caller & ": Delete_First: unexpected exception");
end;
begin
Delete_Last (L);
Put_Line ("ERROR: " & Caller & ": Delete_List: no exception raised");
exception
when List_Empty =>
null;
when Iterated =>
null;
when others =>
Put_Line
("ERROR: " & Caller & ": Delete_Last: unexpected exception");
end;
begin
Destroy (L);
Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception");
end;
begin
Insert_After (L, 1, 2);
Put_Line ("ERROR: " & Caller & ": Insert_After: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line
("ERROR: " & Caller & ": Insert_After: unexpected exception");
end;
begin
Insert_Before (L, 1, 2);
Put_Line
("ERROR: " & Caller & ": Insert_Before: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line
("ERROR: " & Caller & ": Insert_Before: unexpected exception");
end;
begin
Prepend (L, 1);
Put_Line ("ERROR: " & Caller & ": Prepend: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Prepend: unexpected exception");
end;
begin
Replace (L, 1, 2);
Put_Line ("ERROR: " & Caller & ": Replace: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Replace: unexpected exception");
end;
end Check_Locked_Mutations;
-------------------
-- Check_Present --
-------------------
procedure Check_Present
(Caller : String;
L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer)
is
Elem : Integer;
Iter : Iterator;
begin
Iter := Iterate (L);
for Exp_Elem in Low_Elem .. High_Elem loop
Next (Iter, Elem);
if Elem /= Exp_Elem then
Put_Line ("ERROR: " & Caller & ": Check_Present: wrong element");
Put_Line ("expected:" & Exp_Elem'Img);
Put_Line ("got :" & Elem'Img);
end if;
end loop;
-- At this point all elements should have been accounted for. Check for
-- extra elements.
while Has_Next (Iter) loop
Next (Iter, Elem);
Put_Line
("ERROR: " & Caller & ": Check_Present: extra element" & Elem'Img);
end loop;
exception
when Iterator_Exhausted =>
Put_Line
("ERROR: "
& Caller
& "Check_Present: incorrect number of elements");
end Check_Present;
------------------------------
-- Check_Unlocked_Mutations --
------------------------------
procedure Check_Unlocked_Mutations
(Caller : String;
L : in out Doubly_Linked_List)
is
begin
begin
Append (L, 1);
Append (L, 2);
Append (L, 3);
exception
when others =>
Put_Line ("ERROR: " & Caller & ": Append: unexpected exception");
end;
begin
Delete (L, 1);
exception
when others =>
Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
end;
begin
Delete_First (L);
exception
when others =>
Put_Line
("ERROR: " & Caller & ": Delete_First: unexpected exception");
end;
begin
Delete_Last (L);
exception
when others =>
Put_Line
("ERROR: " & Caller & ": Delete_Last: unexpected exception");
end;
begin
Insert_After (L, 2, 3);
exception
when others =>
Put_Line
("ERROR: " & Caller & ": Insert_After: unexpected exception");
end;
begin
Insert_Before (L, 2, 1);
exception
when others =>
Put_Line
("ERROR: " & Caller & ": Insert_Before: unexpected exception");
end;
begin
Prepend (L, 0);
exception
when others =>
Put_Line ("ERROR: " & Caller & ": Prepend: unexpected exception");
end;
begin
Replace (L, 3, 4);
exception
when others =>
Put_Line ("ERROR: " & Caller & ": Replace: unexpected exception");
end;
end Check_Unlocked_Mutations;
--------------------------
-- Populate_With_Append --
--------------------------
procedure Populate_With_Append
(L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer)
is
begin
for Elem in Low_Elem .. High_Elem loop
Append (L, Elem);
end loop;
end Populate_With_Append;
-----------------
-- Test_Append --
-----------------
procedure Test_Append is
L : Doubly_Linked_List := Create;
begin
Append (L, 1);
Append (L, 2);
Append (L, 3);
Append (L, 4);
Append (L, 5);
Check_Present
(Caller => "Test_Append",
L => L,
Low_Elem => 1,
High_Elem => 5);
Destroy (L);
end Test_Append;
-------------------
-- Test_Contains --
-------------------
procedure Test_Contains
(Low_Elem : Integer;
High_Elem : Integer)
is
Low_Bogus : constant Integer := Low_Elem - 1;
High_Bogus : constant Integer := High_Elem + 1;
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, Low_Elem, High_Elem);
-- Ensure that the elements are contained in the list
for Elem in Low_Elem .. High_Elem loop
if not Contains (L, Elem) then
Put_Line
("ERROR: Test_Contains: element" & Elem'Img & " not in list");
end if;
end loop;
-- Ensure that arbitrary elements which were not inserted in the list
-- are not contained in the list.
if Contains (L, Low_Bogus) then
Put_Line
("ERROR: Test_Contains: element" & Low_Bogus'Img & " in list");
end if;
if Contains (L, High_Bogus) then
Put_Line
("ERROR: Test_Contains: element" & High_Bogus'Img & " in list");
end if;
Destroy (L);
end Test_Contains;
-----------------
-- Test_Create --
-----------------
procedure Test_Create is
Count : Natural;
Flag : Boolean;
Iter : Iterator;
L : Doubly_Linked_List;
Val : Integer;
begin
-- Ensure that every routine defined in the API fails on a list which
-- has not been created yet.
begin
Append (L, 1);
Put_Line ("ERROR: Test_Create: Append: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Append: unexpected exception");
end;
begin
Flag := Contains (L, 1);
Put_Line ("ERROR: Test_Create: Contains: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Contains: unexpected exception");
end;
begin
Delete (L, 1);
Put_Line ("ERROR: Test_Create: Delete: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Delete: unexpected exception");
end;
begin
Delete_First (L);
Put_Line ("ERROR: Test_Create: Delete_First: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line
("ERROR: Test_Create: Delete_First: unexpected exception");
end;
begin
Delete_Last (L);
Put_Line ("ERROR: Test_Create: Delete_Last: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Delete_Last: unexpected exception");
end;
begin
Val := First (L);
Put_Line ("ERROR: Test_Create: First: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: First: unexpected exception");
end;
begin
Insert_After (L, 1, 2);
Put_Line ("ERROR: Test_Create: Insert_After: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line
("ERROR: Test_Create: Insert_After: unexpected exception");
end;
begin
Insert_Before (L, 1, 2);
Put_Line ("ERROR: Test_Create: Insert_Before: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line
("ERROR: Test_Create: Insert_Before: unexpected exception");
end;
begin
Flag := Is_Empty (L);
Put_Line ("ERROR: Test_Create: Is_Empty: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Is_Empty: unexpected exception");
end;
begin
Iter := Iterate (L);
Put_Line ("ERROR: Test_Create: Iterate: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Iterate: unexpected exception");
end;
begin
Val := Last (L);
Put_Line ("ERROR: Test_Create: Last: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Last: unexpected exception");
end;
begin
Prepend (L, 1);
Put_Line ("ERROR: Test_Create: Prepend: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Prepend: unexpected exception");
end;
begin
Replace (L, 1, 2);
Put_Line ("ERROR: Test_Create: Replace: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Replace: unexpected exception");
end;
begin
Count := Size (L);
Put_Line ("ERROR: Test_Create: Size: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Size: unexpected exception");
end;
end Test_Create;
-----------------
-- Test_Delete --
-----------------
procedure Test_Delete
(Low_Elem : Integer;
High_Elem : Integer)
is
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, Low_Elem, High_Elem);
-- Delete the first element, which is technically the head
Delete (L, Low_Elem);
-- Ensure that all remaining elements except for the head are present in
-- the list.
Check_Present
(Caller => "Test_Delete",
L => L,
Low_Elem => Low_Elem + 1,
High_Elem => High_Elem);
-- Delete the last element, which is technically the tail
Delete (L, High_Elem);
-- Ensure that all remaining elements except for the head and tail are
-- present in the list.
Check_Present
(Caller => "Test_Delete",
L => L,
Low_Elem => Low_Elem + 1,
High_Elem => High_Elem - 1);
-- Delete all even elements
for Elem in Low_Elem + 1 .. High_Elem - 1 loop
if Elem mod 2 = 0 then
Delete (L, Elem);
end if;
end loop;
-- Ensure that all remaining elements except the head, tail, and even
-- elements are present in the list.
for Elem in Low_Elem + 1 .. High_Elem - 1 loop
if Elem mod 2 /= 0 and then not Contains (L, Elem) then
Put_Line ("ERROR: Test_Delete: missing element" & Elem'Img);
end if;
end loop;
-- Delete all odd elements
for Elem in Low_Elem + 1 .. High_Elem - 1 loop
if Elem mod 2 /= 0 then
Delete (L, Elem);
end if;
end loop;
-- At this point the list should be completely empty
Check_Empty
(Caller => "Test_Delete",
L => L,
Low_Elem => Low_Elem,
High_Elem => High_Elem);
-- Try to delete an element. This operation should raise List_Empty.
begin
Delete (L, Low_Elem);
Put_Line ("ERROR: Test_Delete: List_Empty not raised");
exception
when List_Empty =>
null;
when others =>
Put_Line ("ERROR: Test_Delete: unexpected exception");
end;
Destroy (L);
end Test_Delete;
-----------------------
-- Test_Delete_First --
-----------------------
procedure Test_Delete_First
(Low_Elem : Integer;
High_Elem : Integer)
is
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, Low_Elem, High_Elem);
-- Delete the head of the list, and verify that the remaining elements
-- are still present in the list.
for Elem in Low_Elem .. High_Elem loop
Delete_First (L);
Check_Present
(Caller => "Test_Delete_First",
L => L,
Low_Elem => Elem + 1,
High_Elem => High_Elem);
end loop;
-- At this point the list should be completely empty
Check_Empty
(Caller => "Test_Delete_First",
L => L,
Low_Elem => Low_Elem,
High_Elem => High_Elem);
-- Try to delete an element. This operation should raise List_Empty.
begin
Delete_First (L);
Put_Line ("ERROR: Test_Delete_First: List_Empty not raised");
exception
when List_Empty =>
null;
when others =>
Put_Line ("ERROR: Test_Delete_First: unexpected exception");
end;
Destroy (L);
end Test_Delete_First;
----------------------
-- Test_Delete_Last --
----------------------
procedure Test_Delete_Last
(Low_Elem : Integer;
High_Elem : Integer)
is
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, Low_Elem, High_Elem);
-- Delete the tail of the list, and verify that the remaining elements
-- are still present in the list.
for Elem in reverse Low_Elem .. High_Elem loop
Delete_Last (L);
Check_Present
(Caller => "Test_Delete_Last",
L => L,
Low_Elem => Low_Elem,
High_Elem => Elem - 1);
end loop;
-- At this point the list should be completely empty
Check_Empty
(Caller => "Test_Delete_Last",
L => L,
Low_Elem => Low_Elem,
High_Elem => High_Elem);
-- Try to delete an element. This operation should raise List_Empty.
begin
Delete_Last (L);
Put_Line ("ERROR: Test_Delete_Last: List_Empty not raised");
exception
when List_Empty =>
null;
when others =>
Put_Line ("ERROR: Test_Delete_First: unexpected exception");
end;
Destroy (L);
end Test_Delete_Last;
----------------
-- Test_First --
----------------
procedure Test_First is
Elem : Integer;
L : Doubly_Linked_List := Create;
begin
-- Try to obtain the head. This operation should raise List_Empty.
begin
Elem := First (L);
Put_Line ("ERROR: Test_First: List_Empty not raised");
exception
when List_Empty =>
null;
when others =>
Put_Line ("ERROR: Test_First: unexpected exception");
end;
Populate_With_Append (L, 1, 2);
-- Obtain the head
Elem := First (L);
if Elem /= 1 then
Put_Line ("ERROR: Test_First: wrong element");
Put_Line ("expected: 1");
Put_Line ("got :" & Elem'Img);
end if;
Destroy (L);
end Test_First;
-----------------------
-- Test_Insert_After --
-----------------------
procedure Test_Insert_After is
L : Doubly_Linked_List := Create;
begin
-- Try to insert after a non-inserted element, in an empty list
Insert_After (L, 1, 2);
-- At this point the list should be completely empty
Check_Empty
(Caller => "Test_Insert_After",
L => L,
Low_Elem => 0,
High_Elem => -1);
Append (L, 1); -- 1
Insert_After (L, 1, 3); -- 1, 3
Insert_After (L, 1, 2); -- 1, 2, 3
Insert_After (L, 3, 4); -- 1, 2, 3, 4
-- Try to insert after a non-inserted element, in a full list
Insert_After (L, 10, 11);
Check_Present
(Caller => "Test_Insert_After",
L => L,
Low_Elem => 1,
High_Elem => 4);
Destroy (L);
end Test_Insert_After;
------------------------
-- Test_Insert_Before --
------------------------
procedure Test_Insert_Before is
L : Doubly_Linked_List := Create;
begin
-- Try to insert before a non-inserted element, in an empty list
Insert_Before (L, 1, 2);
-- At this point the list should be completely empty
Check_Empty
(Caller => "Test_Insert_Before",
L => L,
Low_Elem => 0,
High_Elem => -1);
Append (L, 4); -- 4
Insert_Before (L, 4, 2); -- 2, 4
Insert_Before (L, 2, 1); -- 1, 2, 4
Insert_Before (L, 4, 3); -- 1, 2, 3, 4
-- Try to insert before a non-inserted element, in a full list
Insert_Before (L, 10, 11);
Check_Present
(Caller => "Test_Insert_Before",
L => L,
Low_Elem => 1,
High_Elem => 4);
Destroy (L);
end Test_Insert_Before;
-------------------
-- Test_Is_Empty --
-------------------
procedure Test_Is_Empty is
L : Doubly_Linked_List := Create;
begin
if not Is_Empty (L) then
Put_Line ("ERROR: Test_Is_Empty: list is not empty");
end if;
Append (L, 1);
if Is_Empty (L) then
Put_Line ("ERROR: Test_Is_Empty: list is empty");
end if;
Delete_First (L);
if not Is_Empty (L) then
Put_Line ("ERROR: Test_Is_Empty: list is not empty");
end if;
Destroy (L);
end Test_Is_Empty;
------------------
-- Test_Iterate --
------------------
procedure Test_Iterate is
Elem : Integer;
Iter_1 : Iterator;
Iter_2 : Iterator;
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, 1, 5);
-- Obtain an iterator. This action must lock all mutation operations of
-- the list.
Iter_1 := Iterate (L);
-- Ensure that every mutation routine defined in the API fails on a list
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate",
L => L);
-- Obtain another iterator
Iter_2 := Iterate (L);
-- Ensure that every mutation is still locked
Check_Locked_Mutations
(Caller => "Test_Iterate",
L => L);
-- Exhaust the first itertor
while Has_Next (Iter_1) loop
Next (Iter_1, Elem);
end loop;
-- Ensure that every mutation is still locked
Check_Locked_Mutations
(Caller => "Test_Iterate",
L => L);
-- Exhaust the second itertor
while Has_Next (Iter_2) loop
Next (Iter_2, Elem);
end loop;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate",
L => L);
Destroy (L);
end Test_Iterate;
------------------------
-- Test_Iterate_Empty --
------------------------
procedure Test_Iterate_Empty is
Elem : Integer;
Iter : Iterator;
L : Doubly_Linked_List := Create;
begin
-- Obtain an iterator. This action must lock all mutation operations of
-- the list.
Iter := Iterate (L);
-- Ensure that every mutation routine defined in the API fails on a list
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Empty",
L => L);
-- Attempt to iterate over the elements
while Has_Next (Iter) loop
Next (Iter, Elem);
Put_Line
("ERROR: Test_Iterate_Empty: element" & Elem'Img & " exists");
end loop;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate_Empty",
L => L);
Destroy (L);
end Test_Iterate_Empty;
-------------------------
-- Test_Iterate_Forced --
-------------------------
procedure Test_Iterate_Forced
(Low_Elem : Integer;
High_Elem : Integer)
is
Elem : Integer;
Iter : Iterator;
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, Low_Elem, High_Elem);
-- Obtain an iterator. This action must lock all mutation operations of
-- the list.
Iter := Iterate (L);
-- Ensure that every mutation routine defined in the API fails on a list
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Forced",
L => L);
-- Forcibly advance the iterator until it raises an exception
begin
for Guard in Low_Elem .. High_Elem + 1 loop
Next (Iter, Elem);
end loop;
Put_Line
("ERROR: Test_Iterate_Forced: Iterator_Exhausted not raised");
exception
when Iterator_Exhausted =>
null;
when others =>
Put_Line ("ERROR: Test_Iterate_Forced: unexpected exception");
end;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate_Forced",
L => L);
Destroy (L);
end Test_Iterate_Forced;
---------------
-- Test_Last --
---------------
procedure Test_Last is
Elem : Integer;
L : Doubly_Linked_List := Create;
begin
-- Try to obtain the tail. This operation should raise List_Empty.
begin
Elem := First (L);
Put_Line ("ERROR: Test_Last: List_Empty not raised");
exception
when List_Empty =>
null;
when others =>
Put_Line ("ERROR: Test_Last: unexpected exception");
end;
Populate_With_Append (L, 1, 2);
-- Obtain the tail
Elem := Last (L);
if Elem /= 2 then
Put_Line ("ERROR: Test_Last: wrong element");
Put_Line ("expected: 2");
Put_Line ("got :" & Elem'Img);
end if;
Destroy (L);
end Test_Last;
------------------
-- Test_Prepend --
------------------
procedure Test_Prepend is
L : Doubly_Linked_List := Create;
begin
Prepend (L, 5);
Prepend (L, 4);
Prepend (L, 3);
Prepend (L, 2);
Prepend (L, 1);
Check_Present
(Caller => "Test_Prepend",
L => L,
Low_Elem => 1,
High_Elem => 5);
Destroy (L);
end Test_Prepend;
------------------
-- Test_Present --
------------------
procedure Test_Present is
L : Doubly_Linked_List;
begin
if Present (L) then
Put_Line ("ERROR: Test_Present: list does not exist");
end if;
L := Create;
if not Present (L) then
Put_Line ("ERROR: Test_Present: list exists");
end if;
Destroy (L);
end Test_Present;
------------------
-- Test_Replace --
------------------
procedure Test_Replace is
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, 1, 5);
Replace (L, 3, 8);
Replace (L, 1, 6);
Replace (L, 4, 9);
Replace (L, 5, 10);
Replace (L, 2, 7);
Replace (L, 11, 12);
Check_Present
(Caller => "Test_Replace",
L => L,
Low_Elem => 6,
High_Elem => 10);
Destroy (L);
end Test_Replace;
---------------
-- Test_Size --
---------------
procedure Test_Size is
L : Doubly_Linked_List := Create;
S : Natural;
begin
S := Size (L);
if S /= 0 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 0");
Put_Line ("got :" & S'Img);
end if;
Populate_With_Append (L, 1, 2);
S := Size (L);
if S /= 2 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 2");
Put_Line ("got :" & S'Img);
end if;
Populate_With_Append (L, 3, 6);
S := Size (L);
if S /= 6 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 6");
Put_Line ("got :" & S'Img);
end if;
Destroy (L);
end Test_Size;
-- Start of processing for Operations
begin
Test_Append;
Test_Contains
(Low_Elem => 1,
High_Elem => 5);
Test_Create;
Test_Delete
(Low_Elem => 1,
High_Elem => 10);
Test_Delete_First
(Low_Elem => 1,
High_Elem => 5);
Test_Delete_Last
(Low_Elem => 1,
High_Elem => 5);
Test_First;
Test_Insert_After;
Test_Insert_Before;
Test_Is_Empty;
Test_Iterate;
Test_Iterate_Empty;
Test_Iterate_Forced
(Low_Elem => 1,
High_Elem => 5);
Test_Last;
Test_Prepend;
Test_Present;
Test_Replace;
Test_Size;
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/
* libgnat/g-lists.adb: Use type Doubly_Linked_List rather than
Instance in various routines.
* libgnat/g-lists.ads: Change type Instance to
Doubly_Linked_List. Update various routines that mention the
type.
gcc/testsuite/
* gnat.dg/linkedlist.adb: Update.
From-SVN: r272861
Hristian Kirtchev [Mon, 1 Jul 2019 13:34:55 +0000 (13:34 +0000)]
[Ada] Clean up of GNAT.Dynamic_HTables
------------
-- Source --
------------
-- operations.adb
with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT;
with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
procedure Operations is
procedure Destroy (Val : in out Integer) is null;
function Hash (Key : Integer) return Bucket_Range_Type;
package DHT is new Dynamic_Hash_Tables
(Key_Type => Integer,
Value_Type => Integer,
No_Value => 0,
Expansion_Threshold => 1.3,
Expansion_Factor => 2,
Compression_Threshold => 0.3,
Compression_Factor => 2,
"=" => "=",
Destroy_Value => Destroy,
Hash => Hash);
use DHT;
function Create_And_Populate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive) return Dynamic_Hash_Table;
-- Create a hash table with initial size Init_Size and populate it with
-- key-value pairs where both keys and values are in the range Low_Key
-- .. High_Key.
procedure Check_Empty
(Caller : String;
T : Dynamic_Hash_Table;
Low_Key : Integer;
High_Key : Integer);
-- Ensure that
--
-- * The key-value pairs count of hash table T is 0.
-- * All values for the keys in range Low_Key .. High_Key are 0.
procedure Check_Keys
(Caller : String;
Iter : in out Iterator;
Low_Key : Integer;
High_Key : Integer);
-- Ensure that iterator Iter visits every key in the range Low_Key ..
-- High_Key exactly once.
procedure Check_Locked_Mutations
(Caller : String;
T : in out Dynamic_Hash_Table);
-- Ensure that all mutation operations of hash table T are locked
procedure Check_Size
(Caller : String;
T : Dynamic_Hash_Table;
Exp_Count : Natural);
-- Ensure that the count of key-value pairs of hash table T matches
-- expected count Exp_Count. Emit an error if this is not the case.
procedure Test_Create (Init_Size : Positive);
-- Verify that all dynamic hash table operations fail on a non-created
-- table of size Init_Size.
procedure Test_Delete_Get_Put_Size
(Low_Key : Integer;
High_Key : Integer;
Exp_Count : Natural;
Init_Size : Positive);
-- Verify that
--
-- * Put properly inserts values in the hash table.
-- * Get properly retrieves all values inserted in the table.
-- * Delete properly deletes values.
-- * The size of the hash table properly reflects the number of key-value
-- pairs.
--
-- Low_Key and High_Key denote the range of keys to be inserted, retrieved,
-- and deleted. Exp_Count is the expected count of key-value pairs n the
-- hash table. Init_Size denotes the initial size of the table.
procedure Test_Iterate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive);
-- Verify that iterators
--
-- * Properly visit each key exactly once.
-- * Mutation operations are properly locked and unlocked during
-- iteration.
--
-- Low_Key and High_Key denote the range of keys to be inserted, retrieved,
-- and deleted. Init_Size denotes the initial size of the table.
procedure Test_Iterate_Empty (Init_Size : Positive);
-- Verify that an iterator over an empty hash table
--
-- * Does not visit any key
-- * Mutation operations are properly locked and unlocked during
-- iteration.
--
-- Init_Size denotes the initial size of the table.
procedure Test_Iterate_Forced
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive);
-- Verify that an iterator that is forcefully advanced by just Next
--
-- * Properly visit each key exactly once.
-- * Mutation operations are properly locked and unlocked during
-- iteration.
--
-- Low_Key and High_Key denote the range of keys to be inserted, retrieved,
-- and deleted. Init_Size denotes the initial size of the table.
procedure Test_Replace
(Low_Val : Integer;
High_Val : Integer;
Init_Size : Positive);
-- Verify that Put properly updates the value of a particular key. Low_Val
-- and High_Val denote the range of values to be updated. Init_Size denotes
-- the initial size of the table.
procedure Test_Reset
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive);
-- Verify that Reset properly destroy and recreats a hash table. Low_Key
-- and High_Key denote the range of keys to be inserted in the hash table.
-- Init_Size denotes the initial size of the table.
-------------------------
-- Create_And_Populate --
-------------------------
function Create_And_Populate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive) return Dynamic_Hash_Table
is
T : Dynamic_Hash_Table;
begin
T := Create (Init_Size);
for Key in Low_Key .. High_Key loop
Put (T, Key, Key);
end loop;
return T;
end Create_And_Populate;
-----------------
-- Check_Empty --
-----------------
procedure Check_Empty
(Caller : String;
T : Dynamic_Hash_Table;
Low_Key : Integer;
High_Key : Integer)
is
Val : Integer;
begin
Check_Size
(Caller => Caller,
T => T,
Exp_Count => 0);
for Key in Low_Key .. High_Key loop
Val := Get (T, Key);
if Val /= 0 then
Put_Line ("ERROR: " & Caller & ": wrong value");
Put_Line ("expected: 0");
Put_Line ("got :" & Val'Img);
end if;
end loop;
end Check_Empty;
----------------
-- Check_Keys --
----------------
procedure Check_Keys
(Caller : String;
Iter : in out Iterator;
Low_Key : Integer;
High_Key : Integer)
is
type Bit_Vector is array (Low_Key .. High_Key) of Boolean;
pragma Pack (Bit_Vector);
Count : Natural;
Key : Integer;
Seen : Bit_Vector := (others => False);
begin
-- Compute the number of outstanding keys that have to be iterated on
Count := High_Key - Low_Key + 1;
while Has_Next (Iter) loop
Next (Iter, Key);
if Seen (Key) then
Put_Line
("ERROR: " & Caller & ": Check_Keys: duplicate key" & Key'Img);
else
Seen (Key) := True;
Count := Count - 1;
end if;
end loop;
-- In the end, all keys must have been iterated on
if Count /= 0 then
for Key in Seen'Range loop
if not Seen (Key) then
Put_Line
("ERROR: " & Caller & ": Check_Keys: missing key" & Key'Img);
end if;
end loop;
end if;
end Check_Keys;
----------------------------
-- Check_Locked_Mutations --
----------------------------
procedure Check_Locked_Mutations
(Caller : String;
T : in out Dynamic_Hash_Table)
is
begin
begin
Delete (T, 1);
Put_Line ("ERROR: " & Caller & ": Delete: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
end;
begin
Destroy (T);
Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception");
end;
begin
Put (T, 1, 1);
Put_Line ("ERROR: " & Caller & ": Put: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Put: unexpected exception");
end;
begin
Reset (T);
Put_Line ("ERROR: " & Caller & ": Reset: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Reset: unexpected exception");
end;
end Check_Locked_Mutations;
----------------
-- Check_Size --
----------------
procedure Check_Size
(Caller : String;
T : Dynamic_Hash_Table;
Exp_Count : Natural)
is
Count : constant Natural := Size (T);
begin
if Count /= Exp_Count then
Put_Line ("ERROR: " & Caller & ": Size: wrong value");
Put_Line ("expected:" & Exp_Count'Img);
Put_Line ("got :" & Count'Img);
end if;
end Check_Size;
----------
-- Hash --
----------
function Hash (Key : Integer) return Bucket_Range_Type is
begin
return Bucket_Range_Type (Key);
end Hash;
-----------------
-- Test_Create --
-----------------
procedure Test_Create (Init_Size : Positive) is
Count : Natural;
Iter : Iterator;
T : Dynamic_Hash_Table;
Val : Integer;
begin
-- Ensure that every routine defined in the API fails on a hash table
-- which has not been created yet.
begin
Delete (T, 1);
Put_Line ("ERROR: Test_Create: Delete: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Delete: unexpected exception");
end;
begin
Destroy (T);
Put_Line ("ERROR: Test_Create: Destroy: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Destroy: unexpected exception");
end;
begin
Val := Get (T, 1);
Put_Line ("ERROR: Test_Create: Get: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Get: unexpected exception");
end;
begin
Iter := Iterate (T);
Put_Line ("ERROR: Test_Create: Iterate: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Iterate: unexpected exception");
end;
begin
Put (T, 1, 1);
Put_Line ("ERROR: Test_Create: Put: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Put: unexpected exception");
end;
begin
Reset (T);
Put_Line ("ERROR: Test_Create: Reset: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Reset: unexpected exception");
end;
begin
Count := Size (T);
Put_Line ("ERROR: Test_Create: Size: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Size: unexpected exception");
end;
-- Test create
T := Create (Init_Size);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Create;
------------------------------
-- Test_Delete_Get_Put_Size --
------------------------------
procedure Test_Delete_Get_Put_Size
(Low_Key : Integer;
High_Key : Integer;
Exp_Count : Natural;
Init_Size : Positive)
is
Exp_Val : Integer;
T : Dynamic_Hash_Table;
Val : Integer;
begin
T := Create_And_Populate (Low_Key, High_Key, Init_Size);
-- Ensure that its size matches an expected value
Check_Size
(Caller => "Test_Delete_Get_Put_Size",
T => T,
Exp_Count => Exp_Count);
-- Ensure that every value for the range of keys exists
for Key in Low_Key .. High_Key loop
Val := Get (T, Key);
if Val /= Key then
Put_Line ("ERROR: Test_Delete_Get_Put_Size: Get: wrong value");
Put_Line ("expected:" & Key'Img);
Put_Line ("got :" & Val'Img);
end if;
end loop;
-- Delete values whose keys are divisible by 10
for Key in Low_Key .. High_Key loop
if Key mod 10 = 0 then
Delete (T, Key);
end if;
end loop;
-- Ensure that all values whose keys were not deleted still exist
for Key in Low_Key .. High_Key loop
if Key mod 10 = 0 then
Exp_Val := 0;
else
Exp_Val := Key;
end if;
Val := Get (T, Key);
if Val /= Exp_Val then
Put_Line ("ERROR: Test_Delete_Get_Put_Size: Get: wrong value");
Put_Line ("expected:" & Exp_Val'Img);
Put_Line ("got :" & Val'Img);
end if;
end loop;
-- Delete all values
for Key in Low_Key .. High_Key loop
Delete (T, Key);
end loop;
-- Ensure that the hash table is empty
Check_Empty
(Caller => "Test_Delete_Get_Put_Size",
T => T,
Low_Key => Low_Key,
High_Key => High_Key);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Delete_Get_Put_Size;
------------------
-- Test_Iterate --
------------------
procedure Test_Iterate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive)
is
Iter_1 : Iterator;
Iter_2 : Iterator;
T : Dynamic_Hash_Table;
begin
T := Create_And_Populate (Low_Key, High_Key, Init_Size);
-- Obtain an iterator. This action must lock all mutation operations of
-- the hash table.
Iter_1 := Iterate (T);
-- Ensure that every mutation routine defined in the API fails on a hash
-- table with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate",
T => T);
-- Obtain another iterator
Iter_2 := Iterate (T);
-- Ensure that every mutation is still locked
Check_Locked_Mutations
(Caller => "Test_Iterate",
T => T);
-- Ensure that all keys are iterable. Note that this does not unlock the
-- mutation operations of the hash table because Iter_2 is not exhausted
-- yet.
Check_Keys
(Caller => "Test_Iterate",
Iter => Iter_1,
Low_Key => Low_Key,
High_Key => High_Key);
Check_Locked_Mutations
(Caller => "Test_Iterate",
T => T);
-- Ensure that all keys are iterable. This action unlocks all mutation
-- operations of the hash table because all outstanding iterators have
-- been exhausted.
Check_Keys
(Caller => "Test_Iterate",
Iter => Iter_2,
Low_Key => Low_Key,
High_Key => High_Key);
-- Ensure that all mutation operations are once again callable
Delete (T, Low_Key);
Put (T, Low_Key, Low_Key);
Reset (T);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Iterate;
------------------------
-- Test_Iterate_Empty --
------------------------
procedure Test_Iterate_Empty (Init_Size : Positive) is
Iter : Iterator;
Key : Integer;
T : Dynamic_Hash_Table;
begin
T := Create_And_Populate (0, -1, Init_Size);
-- Obtain an iterator. This action must lock all mutation operations of
-- the hash table.
Iter := Iterate (T);
-- Ensure that every mutation routine defined in the API fails on a hash
-- table with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Empty",
T => T);
-- Attempt to iterate over the keys
while Has_Next (Iter) loop
Next (Iter, Key);
Put_Line ("ERROR: Test_Iterate_Empty: key" & Key'Img & " exists");
end loop;
-- Ensure that all mutation operations are once again callable
Delete (T, 1);
Put (T, 1, 1);
Reset (T);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Iterate_Empty;
-------------------------
-- Test_Iterate_Forced --
-------------------------
procedure Test_Iterate_Forced
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive)
is
Iter : Iterator;
Key : Integer;
T : Dynamic_Hash_Table;
begin
T := Create_And_Populate (Low_Key, High_Key, Init_Size);
-- Obtain an iterator. This action must lock all mutation operations of
-- the hash table.
Iter := Iterate (T);
-- Ensure that every mutation routine defined in the API fails on a hash
-- table with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Forced",
T => T);
-- Forcibly advance the iterator until it raises an exception
begin
for Guard in Low_Key .. High_Key + 1 loop
Next (Iter, Key);
end loop;
Put_Line
("ERROR: Test_Iterate_Forced: Iterator_Exhausted not raised");
exception
when Iterator_Exhausted =>
null;
when others =>
Put_Line ("ERROR: Test_Iterate_Forced: unexpected exception");
end;
-- Ensure that all mutation operations are once again callable
Delete (T, Low_Key);
Put (T, Low_Key, Low_Key);
Reset (T);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Iterate_Forced;
------------------
-- Test_Replace --
------------------
procedure Test_Replace
(Low_Val : Integer;
High_Val : Integer;
Init_Size : Positive)
is
Key : constant Integer := 1;
T : Dynamic_Hash_Table;
Val : Integer;
begin
T := Create (Init_Size);
-- Ensure the Put properly updates values with the same key
for Exp_Val in Low_Val .. High_Val loop
Put (T, Key, Exp_Val);
Val := Get (T, Key);
if Val /= Exp_Val then
Put_Line ("ERROR: Test_Replace: Get: wrong value");
Put_Line ("expected:" & Exp_Val'Img);
Put_Line ("got :" & Val'Img);
end if;
end loop;
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Replace;
----------------
-- Test_Reset --
----------------
procedure Test_Reset
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive)
is
T : Dynamic_Hash_Table;
begin
T := Create_And_Populate (Low_Key, High_Key, Init_Size);
-- Reset the contents of the hash table
Reset (T);
-- Ensure that the hash table is empty
Check_Empty
(Caller => "Test_Reset",
T => T,
Low_Key => Low_Key,
High_Key => High_Key);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Reset;
-- Start of processing for Operations
begin
Test_Create (Init_Size => 1);
Test_Create (Init_Size => 100);
Test_Delete_Get_Put_Size
(Low_Key => 1,
High_Key => 1,
Exp_Count => 1,
Init_Size => 1);
Test_Delete_Get_Put_Size
(Low_Key => 1,
High_Key => 1000,
Exp_Count => 1000,
Init_Size => 32);
Test_Iterate
(Low_Key => 1,
High_Key => 32,
Init_Size => 32);
Test_Iterate_Empty (Init_Size => 32);
Test_Iterate_Forced
(Low_Key => 1,
High_Key => 32,
Init_Size => 32);
Test_Replace
(Low_Val => 1,
High_Val => 10,
Init_Size => 32);
Test_Reset
(Low_Key => 1,
High_Key => 1000,
Init_Size => 100);
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/
* libgnat/g-dynhta.adb: Use type Dynamic_Hash_Table rather than
Instance in various routines.
* libgnat/g-dynhta.ads: Change type Instance to
Dynamic_Hash_Table. Update various routines that mention the
type.
gcc/testsuite/
* gnat.dg/dynhash.adb, gnat.dg/dynhash1.adb: Update.
From-SVN: r272860
Hristian Kirtchev [Mon, 1 Jul 2019 13:34:49 +0000 (13:34 +0000)]
[Ada] Minor reformatting
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* exp_attr.adb, exp_ch7.adb, exp_unst.adb, sem_ch3.adb,
sem_util.adb, uintp.adb, uintp.ads: Minor reformatting.
From-SVN: r272859
Javier Miranda [Mon, 1 Jul 2019 13:34:45 +0000 (13:34 +0000)]
[Ada] Disable expansion of 'Min/'Max of floating point types
2019-07-01 Javier Miranda <miranda@adacore.com>
gcc/ada/
* exp_attr.adb (Expand_Min_Max_Attribute): Disable expansion of
'Min/'Max on integer, enumeration, fixed point and floating
point types since the CCG backend now provides in file
standard.h routines to support it.
From-SVN: r272858
Hristian Kirtchev [Mon, 1 Jul 2019 13:34:40 +0000 (13:34 +0000)]
[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
Dmitriy Anisimkov [Mon, 1 Jul 2019 13:34:34 +0000 (13:34 +0000)]
[Ada] GNAT.Sockets: fix Get_Address when AF_INET6 is not defined
2019-07-01 Dmitriy Anisimkov <anisimko@adacore.com>
gcc/ada/
* libgnat/g-sothco.adb (Get_Address): Fix the case when AF_INET6
is not defined.
From-SVN: r272856
Ed Schonberg [Mon, 1 Jul 2019 13:34:30 +0000 (13:34 +0000)]
[Ada] Compiler abort on use of Invalid_Value on numeric positive subtype
Invalid_Value in most cases uses a predefined numeric value from a
built-in table, but if the type does not include zero in its range, the
literal 0 is used instead. In that case the value (produced by a call to
Get_Simple_Init_Val) must be resolved for proper type information.
The following must compile quietly:
gnatmake -q main
----
with Problems; use Problems;
with Text_IO; use Text_IO;
procedure Main is
begin
Put_Line ("P1: " & P1'Image);
Put_Line ("P2: " & P2'Image);
Put_Line ("P3: " & P3'Image);
Put_Line ("P4: " & P4'Image);
end Main;
--
package Problems is
function P1 return Integer;
function P2 return Long_Integer;
-- Max. number of prime factors a number can have is log_2 N
-- For N =
600851475143, this is ~ 40
-- type P3_Factors is array (1 .. 40) of Long_Integer;
function P3 return Long_Integer;
type P4_Palindrome is range 100*100 .. 999*999;
function P4 return P4_Palindrome;
end Problems;
----
package body Problems is
function P1 return Integer is separate;
function P2 return Long_Integer is separate;
function P3 return Long_Integer is separate;
function P4 return P4_Palindrome is separate;
end Problems;
----
separate(Problems)
function P1 return Integer is
Sum : Integer range 0 .. 500_500 := 0;
begin
for I in Integer range 1 .. 1000 - 1 loop
if I mod 3 = 0 or I mod 5 = 0 then
Sum := Sum + I;
end if;
end loop;
return Sum;
end P1;
--
separate(Problems)
function P2 return Long_Integer is
subtype Total is Long_Integer range 0 .. 8_000002e6 ;
subtype Elem is Total range 0 .. 4e7 ;
Sum : Total := 0;
a, b, c : Elem;
begin
a := 1;
b := 2;
loop
if b mod 2 = 0 then
Sum := Sum + b;
end if;
c := b;
b := a + b;
a := c;
exit when b >= 4e6;
end loop;
return Sum;
end P2;
--
with Text_IO; use Text_IO;
with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions;
separate(Problems)
function P3 return Long_Integer is
-- Greatest prime factor
GPF : Long_Integer := 1;
Dividend : Long_Integer :=
600851475143;
Factor : Long_Integer := 2;
Quotient : Long_Integer;
begin
while Dividend > 1 loop
Quotient := Dividend / Factor;
if Dividend mod Factor = 0 then
GPF := Factor;
Dividend := Quotient;
else
if Factor >= Quotient then
GPF := Dividend;
exit;
end if;
Factor := Factor + 1;
end if;
end loop;
return GPF;
end P3;
----
with Text_IO; use Text_IO;
separate(Problems)
function P4 return P4_Palindrome is
type TripleDigit is range 100 .. 999;
a, b: TripleDigit := TripleDigit'First;
c : P4_Palindrome;
Max_Palindrome : P4_Palindrome := P4_Palindrome'Invalid_Value;
function Is_Palindrome (X : in P4_Palindrome) return Boolean is
type Int_Digit is range 0 .. 9;
type Int_Digits is array (1 .. 6) of Int_Digit;
type Digit_Extractor is range 0 .. P4_Palindrome'Last;
Y : Digit_Extractor := Digit_Extractor (X);
X_Digits : Int_Digits;
begin
for I in reverse X_Digits'Range loop
X_Digits (I) := Int_Digit (Y mod 10);
Y := Y / 10;
end loop;
return
(X_Digits (1) = X_Digits (6) and X_Digits (2) = X_Digits (5) and
X_Digits (3) = X_Digits (4)) or
(X_Digits (2) = X_Digits (6) and X_Digits (3) = X_Digits (5) and
X_Digits(1) = 0);
end Is_Palindrome;
begin
for a in TripleDigit'Range loop
for b in TripleDigit'Range loop
c := P4_Palindrome (a * b);
if Is_Palindrome (c) then
if Max_Palindrome'Valid or else c > Max_Palindrome then
Max_Palindrome := c;
end if;
end if;
end loop;
end loop;
return Max_Palindrome;
end;
2019-07-01 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* exp_attr.adb (Expand_Attribute_Reference, case Invalid_Value):
Resolve result of call to Get_Simple_Init_Val, which may be a
conversion of a literal.
From-SVN: r272855
Hristian Kirtchev [Mon, 1 Jul 2019 13:34:25 +0000 (13:34 +0000)]
[Ada] Crash due to missing freeze nodes in transient scope
The following patch updates the freezing of expressions to insert the
generated freeze nodes prior to the expression that produced them when
the context is a transient scope within a type initialization procedure.
This ensures that the nodes are properly interleaved with respect to the
constructs that generated them.
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* freeze.adb (Freeze_Expression): Remove the horrible useless
name hiding of N. Insert the freeze nodes generated by the
expression prior to the expression when the nearest enclosing
scope is transient.
gcc/testsuite/
* gnat.dg/freezing1.adb, gnat.dg/freezing1.ads,
gnat.dg/freezing1_pack.adb, gnat.dg/freezing1_pack.ads: New
testcase.
From-SVN: r272854
Pierre-Marie de Rodat [Mon, 1 Jul 2019 13:34:19 +0000 (13:34 +0000)]
[Ada] Fix formatting issues in the gnat_ugn documentation
2019-07-01 Pierre-Marie de Rodat <derodat@adacore.com>
gcc/ada/
* doc/gnat_ugn/building_executable_programs_with_gnat.rst: Fix
formatting issues in the -gnatR section.
* gnat_ugn.texi: Regenerate.
From-SVN: r272853
Jan Hubicka [Mon, 1 Jul 2019 09:05:07 +0000 (11:05 +0200)]
re PR lto/91028 (g++.dg/lto/alias-2 FAILs with -fno-use-linker-plugin)
PR lto/91028
PR lto/90720
* g++.dg/lto/alias-1_0.C: Add loop to make inlining happen with
-fno-use-linker-plugin
* g++.dg/lto/alias-2_0.C: Likewise.
From-SVN: r272852
Richard Sandiford [Mon, 1 Jul 2019 08:58:44 +0000 (08:58 +0000)]
Use ira_setup_alts for conflict detection
make_early_clobber_and_input_conflicts records allocno conflicts
between inputs and earlyclobber outputs. It (rightly) avoids
doing this for inputs that are explicitly allowed to match the
output due to matching constraints.
The problem is that whether this matching is allowed varies
between alternatives. At the moment the code avoids adding
a clobber if *any* enabled alternative allows the match,
even if some other operand makes that alternative impossible.
The specific instance of this for SVE is that some alternatives
allow matched earlyclobbers when a third operand X is constant zero.
We should avoid adding conflicts when X really is constant zero,
but should ignore the match if X is nonzero or nonconstant.
ira_setup_alts can already filter these alternatives out for us,
so all we need to do is use it in process_bb_node_lives. The
preferred_alternatives variable is only used for this earlyclobber
detection, so no other check should be affected.
With the previous patch to check the reject weight in ira_setup_alts,
this has the effect of ignoring expensive alternatives if we have
other valid alternatives with zero cost. It seems reasonable to base
the heuristic on only the alternatives that we'd actually like to use,
but if this ends up being too aggressive, we could instead make the new
reject behaviour conditional and only use it for add_insn_allocno_copies.
2019-07-01 Richard Sandiford <richard.sandiford@arm.com>
gcc/
* ira-lives.c (process_bb_node_lives): Use ira_setup_alts.
From-SVN: r272851
Richard Sandiford [Mon, 1 Jul 2019 08:58:35 +0000 (08:58 +0000)]
Allow earlyclobbers in ira_get_dup_out_num
ira_get_dup_out_num punted on operands that are matched to
earlyclobber outputs:
/* It is better ignore an alternative with early clobber. */
else if (*str == '&')
goto fail;
But I'm not sure why this is the right thing to do. At this stage
we've established that *all* alternatives of interest require the
input to match the output, so
(a) the earlyclobber can only affect other operands and
(b) not tying the registers is bound to introduce a move
The code was part of the initial commit and so isn't obviously
related to a specific testcase. Also, I can imagine LRA makes
a much better job of this situation than reload did. (Certainly
SVE uses matched earlyclobbers extensively and I haven't seen any
problems.)
In case this turns out to regress something important: the main
case that matters for SVE is the one in which all alternatives
are earlyclobber.
2019-07-01 Richard Sandiford <richard.sandiford@arm.com>
gcc/
* ira.c (ira_get_dup_out_num): Don't punt for earlyclobbers.
Use recog_data to test for an output operand.
From-SVN: r272850
Richard Sandiford [Mon, 1 Jul 2019 08:58:23 +0000 (08:58 +0000)]
Make ira_get_dup_out_num handle more cases
SVE has a prefix instruction (MOVPRFX) that acts as a move but is
designed to be easily fusible with the following instruction. The SVE
port therefore has lots of patterns with constraints of the form:
A: operand 0: =w,?w
...
operand n: 0, w
where the first alternative is a single instruction and the second
alternative uses MOVPRFX.
Ideally we want operand n to be allocated to the same register as
operand 0 in this case.
add_insn_allocno_copies is the main IRA routine that deals with tied
operands. It is (rightly) very conservative, and only handles cases in
which we're confident about saving a full move. So for a pattern like:
B: operand 0: =w,w
...
operand n: 0,w
we don't (and shouldn't) assume that tying operands 0 and n would
save the cost of a move.
But in A, the second alternative has a ? marker, which makes it more
expensive than the first alternative by a full reload. So I think for
copy elision we should ignore the untied operand n in the second
alternative of A.
One approach would be to add '*' markers to each pattern and make
ira_get_dup_out_num honour them. But I think the rule applies on
first principles, so marking with '*' shouldn't be necessary.
This patch instead makes ira_get_dup_out_num ignore expensive
alternatives if there are other alternatives that match exactly.
The cheapest way of doing that seemed to be to take expensive
alternatives out of consideration in ira_setup_alts, which provides
a bitmask of alternatives and has all the information available.
add_insn_allocno_copies is the only current user of ira_setup_alts,
so no other code should be affected.
If all available alternatives are disparaged or need a reload,
there's not much we can do to cut them down at this stage,
since it's hard to predict which operands will be reloaded and
which registers will need to be spilled.
An interesting case is patterns like this msp430 one:
;; Alternatives 2 and 3 are to handle cases generated by reload.
(define_insn "subqi3"
[(set (match_operand:QI 0 "nonimmediate_operand" "=rYs, rm, &?r, ?&r")
(minus:QI (match_operand:QI 1 "general_operand" "0, 0, !r, !i")
(match_operand:QI 2 "general_operand" " riYs, rmi, rmi, r")))]
""
"@
SUB.B\t%2, %0
SUB%X0.B\t%2, %0
MOV%X0.B\t%1, %0 { SUB%X0.B\t%2, %0
MOV%X0.B\t%1, %0 { SUB%X0.B\t%2, %0"
)
Here alternative 3 is significantly more expensive then alternative 0
(reject costs 0 and 606 respectively). But if operand 1 is an integer
constant, we'll still use alternative 3 if operand 2 is an allocated
register. On the other hand, if operand 1 is an integer constant but
operand 2 is spilled to memory, we'll move the constant into a register
and use the first alternative.
So in this case, if operand 1 is a register, we should consider
only the first two alternatives and thus try to tie operand 1
to operand 0 (which we didn't do previously). If operand 1 is a
constant integer, we should consider at least alternatives 0, 1 and 3.
We could exclude alternative 2, but I don't have any evidence that
that's useful.
2019-07-01 Richard Sandiford <richard.sandiford@arm.com>
gcc/
* ira.c (ira_setup_alts): If any valid alternatives have zero cost,
exclude any others that are disparaged or that are bound to need
a reload or spill.
(ira_get_dup_out_num): Expand comment.
From-SVN: r272849
Richard Sandiford [Mon, 1 Jul 2019 08:58:10 +0000 (08:58 +0000)]
Simplify ira_setup_alts
ira_setup_alts has its own code to calculate the start of the
constraint string for each operand/alternative combination,
but preprocess_constraints now provides that information in (almost)
constant time for non-asm instructions. Using it here should speed
up the common case at the cost of potentially slowing down the handling
of asm statements.
The real reason for doing this is that a later patch wants to use
more of the operand_alternative information.
2019-07-01 Richard Sandiford <richard.sandiford@arm.com>
gcc/
* ira.c (ira_setup_alts): Use preprocess_constraints to get the
constraint string for each operand/alternative combo. Only handle
'%' at the start of constraint strings, and look for it outside
the main loop.
From-SVN: r272848
Richard Sandiford [Mon, 1 Jul 2019 08:57:59 +0000 (08:57 +0000)]
Use alternative_mask for add_insn_allocno_copies
add_insn_allocno_copies and its subroutines used HARD_REG_SET to
represent a bitmask of alternatives. There's not really any connection
between the number of registers and the maximum number of alternatives,
so this patch uses alternative_mask instead (which wasn't around when
this code was added).
This is just a minor clean-up making way for later patches.
2019-07-01 Richard Sandiford <richard.sandiford@arm.com>
gcc/
* ira-int.h (ira_setup_alts, ira_get_dup_out_num): Use
alternative_mask instead of HARD_REG_SET to represent a
bitmask of alternatives.
* ira.c (ira_setup_alts, ira_get_dup_out_num): Likewise.
* ira-conflicts.c (add_insn_allocno_copies): Likewise.
From-SVN: r272847
Martin Liska [Mon, 1 Jul 2019 08:08:29 +0000 (10:08 +0200)]
Fix 2 clang warnings.
2019-07-01 Martin Liska <mliska@suse.cz>
* edit-context.c (test_applying_fixits_unreadable_file): Do not
use () for a constructor call.
(test_applying_fixits_line_out_of_range): Likewise.
* ggc-page.c (alloc_page): Use (void *) for %p printf format
argument.
(free_page): Likewise.
From-SVN: r272846
Vladislav Ivanishin [Mon, 1 Jul 2019 08:05:51 +0000 (08:05 +0000)]
gdbhooks.py: rename parameters to match usage
gcc/
* gdbhooks.py (GdbPrettyPrinters.add_printer_for_types): Reorder
parameter names to match usage (no functional change).
(GdbPrettyPrinters.add_printer_for_regex): Ditto.
From-SVN: r272845
Dominique d'Humieres [Mon, 1 Jul 2019 08:05:39 +0000 (10:05 +0200)]
gen-attrs-67.C: Add error for darwin.
2019-07-01 Dominique d'Humieres <dominiq@gcc.gnu.org>
* g++.dg/cpp0x/gen-attrs-67.C: Add error for darwin.
From-SVN: r272844
Richard Biener [Mon, 1 Jul 2019 07:54:38 +0000 (07:54 +0000)]
tree-ssa-sccvn.c (class pass_fre): Add may_iterate pass parameter.
2019-07-01 Richard Biener <rguenther@suse.de>
* tree-ssa-sccvn.c (class pass_fre): Add may_iterate
pass parameter.
(pass_fre::execute): Honor it.
* passes.def: Adjust pass_fre invocations to allow iterating,
add non-iterating pass_fre before late threading/dom.
* gcc.dg/tree-ssa/pr77445-2.c: Adjust.
From-SVN: r272843
Richard Biener [Mon, 1 Jul 2019 07:37:28 +0000 (07:37 +0000)]
tree-ssa-sccvn.c (copy_reference_ops_from_ref): Adjust TARGET_MEM_REF handling to also handle address-taken ones.
2019-07-01 Richard Biener <rguenther@suse.de>
* tree-ssa-sccvn.c (copy_reference_ops_from_ref): Adjust
TARGET_MEM_REF handling to also handle address-taken ones.
From-SVN: r272842
Hongtao Liu [Mon, 1 Jul 2019 02:12:42 +0000 (02:12 +0000)]
sourcebuild.texi (Effective-Target Keywords, [...]): Document avx512vp2intersect.
gcc/
2019-07-01 Hongtao Liu <hongtao.liu@intel.com>
* doc/sourcebuild.texi (Effective-Target Keywords, Other
hardware attributes): Document avx512vp2intersect.
gcc/testsuite/
2019-07-01 Hongtao Liu <hongtao.liu@intel.com>
* lib/target-supports.exp
(check_effective_target_avx512vp2intersect): New proc.
* gcc.target/i386/avx512vp2intersect-2intersect-1b.c: Add
dg-require-effective-target avx512vp2intersect.
* gcc.target/i386/avx512vp2intersect-2intersectvl-1b.c: Ditto.
From-SVN: r272840
GCC Administrator [Mon, 1 Jul 2019 00:16:17 +0000 (00:16 +0000)]
Daily bump.
From-SVN: r272839
Uros Bizjak [Sun, 30 Jun 2019 21:12:07 +0000 (23:12 +0200)]
sse.md (ssse3_abs<mode>2): Rename from abs<mode>2.
* config/i386/sse.md (ssse3_abs<mode>2): Rename from abs<mode>2.
(abs<mode>2): New expander.
* config/i386/i386-builtin.def (__builtin_ia32_pabsb):
Use CODE_FOR_ssse3_absv8qi2.
(__builtin_ia32_pabsw): Use CODE_FOR_ssse3_absv4hi2.
(__builtin_ia32_pabsd): Use CODE_FOR_ssse3_absv2si2.
From-SVN: r272835
Uros Bizjak [Sun, 30 Jun 2019 19:40:32 +0000 (21:40 +0200)]
i386.md (mmx_isa): Rename x64, x64_noavx and x64_avx to sse, sse_noavx and avx.
* config/i386/i386.md (mmx_isa): Rename x64, x64_noavx and x64_avx
to sse, sse_noavx and avx. Update all uses.
* config/i386/mmx.md (sse_movntq): Add "isa" attribute.
(*mmx_<plusminus_insn><mode>3): Ditto.
(*mmx_mulv4hi3"): Ditto.
(*mmx_smulv4hi3_highpart): Ditto.
(*mmx_umulv4hi3_highpart): Ditto.
(*mmx_pmaddwd): Ditto.
(*sse2_umulv1siv1di3): Ditto.
(*mmx_<code>v4hi3): Ditto.
(*mmx_<code>v8qi3): Ditto.
(mmx_ashr<mode>3): Ditto.
("mmx_<shift_insn><mode>3): Ditto.
(*mmx_eq<mode>3): Ditto.
(mmx_gt<mode>3): Ditto.
(mmx_andnot<mode>3): Ditto.
(*mmx_<code><mode>3): Ditto.
(*mmx_pinsrw): Ditto.
(*mmx_pextrw): Ditto.
(mmx_pshufw_1): Ditto.
(*mmx_uavgv8qi3): Ditto.
(*mmx_uavgv4hi3): Ditto.
("mmx_psadbw): Ditto.
* config/i386/sse.md (sse_cvtps2pi): Ditto.
(sse_cvttps2pi): Ditto.
(ssse3_pmaddubsw): Ditto.
(*ssse3_pmulhrswv4hi3): Ditto.
(ssse3_psign<mode>3): Ditto.
From-SVN: r272834
Iain Sandoe [Sun, 30 Jun 2019 14:58:45 +0000 (14:58 +0000)]
[PATCH, Ada] Push -shared-libgcc where needed.
Gnatlink has code that checks for duplicate '-shared-libgcc’ switches (but not
duplicate ‘static-libgcc’) and also pushes ’static-libgcc' onto the link line for
targets that default to static linking, provided '-shared-libgcc' is not present.
For targets that should use a shared libgcc we need the same process to be
applied (in inverse), in the event that they do not default to providing the
shared flag implicitly.
So this adds the complementary set of tests for the shared case and pushes
the shared flag as needed. As a minor tidy-up there’s no need push duplicates
of the libgcc switch onto the link line when one has already been seen (given by
the user).
The patch does not alter any of the platform defaults for static/shared libgcc,
but it ensures that the intent of the link is explicit.
gcc/ada/
2019-06-30 Iain Sandoe <iain@sandoe.co.uk>
* gnatlink.adb (Link_Step): Remove duplicate -static-libgcc switches.
Push -shared-libgcc explicitly, when it is the target default (unless
overidden by the static flag).
When the user has put an instance of shared/static-libgcc do not push
a duplicate of this.
From-SVN: r272832
GCC Administrator [Sun, 30 Jun 2019 00:16:25 +0000 (00:16 +0000)]
Daily bump.
From-SVN: r272831
Eric Botcazou [Sat, 29 Jun 2019 09:01:27 +0000 (09:01 +0000)]
decl.c (gnat_to_gnu_entity): Beep up comment on SAVED...
* gcc-interface/decl.c (gnat_to_gnu_entity): Beep up comment on SAVED,
and tweak comment on the assertion about the scopes of Itypes. Do not
skip the regular processing for Itypes that are E_Record_Subtype with
a Cloned_Subtype. Get the Cloned_Subtype for every E_Record_Subtype
if the type is dummy and hasn't got its own freeze node.
<E_Record_Subtype>: Save again the DECL of the Cloned_Subtype, if any.
<E_Access_Subtype>: Save again the DECL of the equivalent type.
(Gigi_Equivalent_Type) <E_Access_Subtype>: New case.
From-SVN: r272822
Eric Botcazou [Sat, 29 Jun 2019 08:22:35 +0000 (08:22 +0000)]
utils.c (unchecked_convert): Tweak comment.
* gcc-interface/utils.c (unchecked_convert): Tweak comment. Only skip
dereferences when padding to have the same size on both sides. Do it
for destination types with self-referential size too.
From-SVN: r272821
Eric Botcazou [Sat, 29 Jun 2019 08:10:20 +0000 (08:10 +0000)]
decl.c (gnat_to_gnu_entity): If the type requires strict alignment, then set the RM size to the type size.
* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: If the
type requires strict alignment, then set the RM size to the type size.
Rework handling of alignment and sizes of tagged types in ASIS mode.
(validate_size): Rename local variable and remove special handling for
strict-alignment types.
* gcc-interface/utils.c (finish_record_type): Constify local variables
and use properly typed constants.
From-SVN: r272820
Eric Botcazou [Sat, 29 Jun 2019 07:53:27 +0000 (07:53 +0000)]
decl.c (gnat_to_gnu_field): Rework error messages for fields requiring strict alignment...
* gcc-interface/decl.c (gnat_to_gnu_field): Rework error messages for
fields requiring strict alignment, add explicit test on Storage_Unit
for position and size, and mention type alignment for position.
From-SVN: r272819
Eric Botcazou [Sat, 29 Jun 2019 07:37:31 +0000 (07:37 +0000)]
trans.c (mark_visited_r): Set TYPE_SIZES_GIMPLIFIED on the main variant of a type, if any.
* gcc-interface/trans.c (mark_visited_r): Set TYPE_SIZES_GIMPLIFIED on
the main variant of a type, if any.
From-SVN: r272815
Eric Botcazou [Sat, 29 Jun 2019 07:30:22 +0000 (07:30 +0000)]
decl.c (set_nonaliased_component_on_array_type): Add missing guard for the presence of TYPE_CANONICAL.
* gcc-interface/decl.c (set_nonaliased_component_on_array_type): Add
missing guard for the presence of TYPE_CANONICAL.
(set_reverse_storage_order_on_array_type): Likewise.
From-SVN: r272811
Eric Botcazou [Sat, 29 Jun 2019 07:16:37 +0000 (07:16 +0000)]
expr.c (expand_expr_real_1): Apply the big-endian adjustment for bit-fields to all aggregate types.
* expr.c (expand_expr_real_1) <BIT_FIELD_REF>: Apply the big-endian
adjustment for bit-fields to all aggregate types.
ada/
* gcc-interface/gigi.h (make_packable_type): Remove default value.
(value_factor_p): Tweak prototype.
* gcc-interface/decl.c (gnat_to_gnu_entity): Add comment.
(gnat_to_gnu_component_type): Likewise.
(gnat_to_gnu_field): Likewise. Fetch the position of the field earlier
and simplify the condition under which the type is packed. Declare
local variable is_bitfield. Pass 1 as max_align to make_packable_type
if it is set to true.
(copy_and_substitute_in_layout): Pass 0 to make_packable_type.
* gcc-interface/utils.c (make_packable_array_type): New function.
(make_packable_type): Use it to rewrite the type of array field.
(maybe_pad_type): Pass align parameter to make_packable_type.
(create_field_decl): Minor tweaks.
(value_factor_p): Assert that FACTOR is a power of 2 and replace the
modulo computation by a masking operation.
From-SVN: r272810
Jason Merrill [Sat, 29 Jun 2019 05:40:58 +0000 (01:40 -0400)]
Remove trailing whitespace in C++ front end.
From-SVN: r272809
GCC Administrator [Sat, 29 Jun 2019 00:16:16 +0000 (00:16 +0000)]
Daily bump.
From-SVN: r272808
Michael Meissner [Fri, 28 Jun 2019 20:19:54 +0000 (20:19 +0000)]
Update pc-relative support.
2019-06-28 Michael Meissner <meissner@linux.ibm.com>
* config/rs6000/predicates.md (pcrel_address): Use
SYMBOL_REF_LOCAL_P to determine if a label is local.
(pcrel_external_address): New predicate.
(non_prefixed_mem_operand): Delete, predicate not used.
* config/rs6000/rs6000.h (SYMBOL_FLAG_PCREL_P): Delete, we now use
SYMBOL_REF_LOCAL_P to determine if we can use pc-relative
addressing.
(SYMBOL_REF_PCREL_P): Likewise.
From-SVN: r272792
Michael Meissner [Fri, 28 Jun 2019 19:52:52 +0000 (19:52 +0000)]
re PR target/91009 (Bug with future PowerPC patches with lfiwax/lfiwzx (related to PR 90822))
Fix PR target/91009
2019-06-27 Michael Meissner <meissner@linux.ibm.com>
PR target/91009
* config/rs6000/rs6000.md (floatsi<mode>2_lfiwax): Add non-VSX
alternative.
(floatsi<mode>2_lfiwax_mem): Add non-VSX alternative.
(floatunssi<mode>2_lfiwzx): Add non-VSX alternative.
(floatunssi<mode>2_lfiwzx_mem): Add non-VSX alternative.
From-SVN: r272791
Iain Sandoe [Fri, 28 Jun 2019 18:51:09 +0000 (18:51 +0000)]
[Darwin, PPC] Install the same headers as other sub-targets.
This is primarily in order to improve testsuite coverage, we might elect
to prune the list at some point.
2019-06-28 Iain Sandoe <iain@sandoe.co.uk>
* config.gcc (powerpc-*-darwin*, powerpc64-*-darwin*): Remove
override on extra_headers.
From-SVN: r272790
Iain Sandoe [Fri, 28 Jun 2019 18:41:09 +0000 (18:41 +0000)]
[Darwin] Fix a couple of Wformat-diag build warnings.
2019-06-28 Iain Sandoe <iain@sandoe.co.uk>
* config/darwin-c.c (pop_field_alignment): Quote #pragma options.
* config/darwin-driver.c (darwin_default_min_version): Remove newline
from warning.
(darwin_driver_init): Likewise.
From-SVN: r272789
Jan Beulich [Fri, 28 Jun 2019 13:21:53 +0000 (13:21 +0000)]
x86: improve GFNI insns
There's no need for three alternatives: "v" without TARGET_AVX512F is
the same as "x".
From-SVN: r272784
Jan Beulich [Fri, 28 Jun 2019 13:19:51 +0000 (13:19 +0000)]
x86: fix vgf2p8affine*qb insns
The affine transformations are not commutative (the two source operands
have entirely different meaning).
Also the nonimmediate_operand predicate can better be vector_operand.
From-SVN: r272783
Claudiu Zissulescu [Fri, 28 Jun 2019 13:14:12 +0000 (15:14 +0200)]
[ARC][COMMITTED] Fix slsr-13 regressions.
A recent RTX cost commit has changed the costs for ARC700 leading to errors in slsr-13.c test.
This commit fixes this issue by reverting the cost computation for short instructions.
2019-06-28 Claudiu Zissulescu <claziss@synopsys.com>
* config/arc/arc.c (arc_rtx_costs): All short instructions are
having a lower cost regardless of the speed option.
From-SVN: r272782
Jan Beulich [Fri, 28 Jun 2019 08:49:23 +0000 (08:49 +0000)]
add file missing from earlier commit
From-SVN: r272781
Jan Beulich [Fri, 28 Jun 2019 08:46:56 +0000 (08:46 +0000)]
x86: fix CVT{,T}PD2PI insns
With just an "m" constraint misaligned memory operands won't be forced
into a register, and hence cause #GP. So far this was guaranteed only
in the case that CVT{,T}PD2DQ were chosen (which looks to be the case on
x86-64 only).
Switch the second alternative to Bm and also replace
nonimmediate_operand by vector_operand.
From-SVN: r272780
Dennis Zhang [Fri, 28 Jun 2019 08:42:09 +0000 (08:42 +0000)]
[Arm] Remove constraint strings from define_expand constructs in the back end
A number of Arm define_expand patterns have specified constraints for
their operands. But the constraint strings are ignored at expand time
and are therefore redundant/useless. We now avoid specifying constraints
in new define_expands, but we should clean up the existing define_expand
definitions.
2019-06-28 Dennis Zhang <dennis.zhang@arm.com>
* config/arm/arm.md: Remove redundant constraints from
define_expand but leave reload_inm and reload_outm patterns
untouched since they need special constraints to work.
* config/arm/arm-fixed.md: Remove redundant constraints from
define_expand.
* config/arm/iwmmxt.md: Likewise.
* config/arm/neon.md: Likewise.
* config/arm/sync.md: Likewise.
* config/arm/thumb1.md: Likewise.
* config/arm/vec-common.md: Likewise.
From-SVN: r272779
GCC Administrator [Fri, 28 Jun 2019 00:16:16 +0000 (00:16 +0000)]
Daily bump.
From-SVN: r272774
Ilia Diachkov [Thu, 27 Jun 2019 23:41:03 +0000 (23:41 +0000)]
Add --disable-tm-clone-registry libgcc configure option.
This patch adds libgcc configuration option to disable TM clone
registry. This option helps to reduce code size for embedded targets
which do not need transactional memory support.
gcc/
* doc/install.texi: Document --disable-tm-clone-registry.
libgcc/
* Makefile.in (USE_TM_CLONE_REGISTRY): New.
(CRTSTUFF_CFLAGS): Use USE_TM_CLONE_REGISTRY.
* configure.ac: Add --disable-tm-clone-registry option.
* configure: Regenerate.
From-SVN: r272769
Jason Merrill [Thu, 27 Jun 2019 21:29:19 +0000 (17:29 -0400)]
PR c++/55442 - memory-hog with highly recursive constexpr.
This testcase in the PR is extremely recursive, and therefore uses a huge
amount of memory on caching the results of individual calls. We no longer
need to track all calls to catch infinite recursion, as we have other limits
on maximum depth and operations count. So let's only cache a few calls at
the top level: 8 seems to be a reasonable compromise.
gcc/c-family/
* c.opt (fconstexpr-loop-limit): New.
gcc/cp/
* constexpr.c (push_cx_call_context): Return depth.
(cxx_eval_call_expression): Don't cache past constexpr_cache_depth.
From-SVN: r272765
Jakub Jelinek [Thu, 27 Jun 2019 21:25:56 +0000 (23:25 +0200)]
re PR c++/91024 (-Wimplicit-fallthrough is confused by likely/unlikely attributes)
PR c++/91024
* gimplify.c (collect_fallthrough_labels): Ignore GIMPLE_PREDICT
statements.
* g++.dg/warn/Wimplicit-fallthrough-4.C: New test.
From-SVN: r272764
Jakub Jelinek [Thu, 27 Jun 2019 21:23:09 +0000 (23:23 +0200)]
re PR tree-optimization/91010 (ICE: Segmentation fault (in location_wrapper_p))
PR tree-optimization/91010
* tree-vect-stmts.c (scan_operand_equal_p): If offset1 == offset2,
return true. Otherwise, don't call operand_equal_p if offset1 or
offset2 is NULL and just return false.
* g++.dg/vect/simd-10.cc: New test.
From-SVN: r272763
Iain Sandoe [Thu, 27 Jun 2019 19:08:16 +0000 (19:08 +0000)]
[Darwin, PPC] Allow the user to override the use of hard float in kexts.
The default for the kernel is soft-float, however a user writing a kernel
extension might want to make use of hard float. This change makes
" -mkernel -mhard-float " work as expected.
2019-06-27 Iain Sandoe <iain@sandoe.co.uk>
* config/rs6000/rs6000.c (darwin_rs6000_override_options): Honour
user-specified float mode choice for kernel mode code.
From-SVN: r272760
Iain Sandoe [Thu, 27 Jun 2019 19:01:57 +0000 (19:01 +0000)]
[Darwin, PPC] Correct whitespace in specs.
A recent merge dropped whitespace in the endfile specs, which affects
transactional memory cases.
2019-06-27 Iain Sandoe <iain@sandoe.co.uk>
* config/rs6000/darwin.h (ENDFILE_SPEC): Correct whitespace in the
spec.
From-SVN: r272759
Iain Sandoe [Thu, 27 Jun 2019 18:56:53 +0000 (18:56 +0000)]
[Darwin, PPC] Do not use longcall for 64b code.
The linker [ld64] that supports 64Bit does not need the JBSR longcall
optimisation, and will not work with the most generic case (where the
symbol is undefined external, but there is no symbl stub). So switch
the longcall option off. ld64 will generate branch islands as needed.
2019-06-27 Iain Sandoe <iain@sandoe.co.uk>
* config/rs6000/rs6000.c (darwin_rs6000_override_options): Do not
use longcall for 64b code.
From-SVN: r272758
Steven G. Kargl [Thu, 27 Jun 2019 17:52:00 +0000 (17:52 +0000)]
re PR fortran/90987 (Wrong error message with variables named "COMMON*")
2019-06-27 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/90987
* match.c (gfc_match_common): Adjust parsing of fixed and free form
source code containing, e.g., COMMONI.
2019-06-27 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/90987
* gfortran.dg/common_1.f: new test.
* gfortran.dg/common_26.f90: Ditto.
From-SVN: r272756
Aaron Sawdey [Thu, 27 Jun 2019 14:45:36 +0000 (14:45 +0000)]
builtins.c (get_memory_rtx): Fix comment.
2019-06-27 Aaron Sawdey <acsawdey@linux.ibm.com>
* builtins.c (get_memory_rtx): Fix comment.
* optabs.def (movmem_optab): Change to cpymem_optab.
* expr.c (emit_block_move_via_cpymem): Change movmem to cpymem.
(emit_block_move_hints): Change movmem to cpymem.
* defaults.h: Change movmem to cpymem.
* targhooks.c (get_move_ratio): Change movmem to cpymem.
(default_use_by_pieces_infrastructure_p): Ditto.
* config/aarch64/aarch64-protos.h: Change movmem to cpymem.
* config/aarch64/aarch64.c (aarch64_expand_movmem): Change movmem
to cpymem.
* config/aarch64/aarch64.h: Change movmem to cpymem.
* config/aarch64/aarch64.md (movmemdi): Change name to cpymemdi.
* config/alpha/alpha.h: Change movmem to cpymem in comment.
* config/alpha/alpha.md (movmemqi, movmemdi, *movmemdi_1): Change
movmem to cpymem.
* config/arc/arc-protos.h: Change movmem to cpymem.
* config/arc/arc.c (arc_expand_movmem): Change movmem to cpymem.
* config/arc/arc.h: Change movmem to cpymem in comment.
* config/arc/arc.md (movmemsi): Change movmem to cpymem.
* config/arm/arm-protos.h: Change movmem to cpymem in names.
* config/arm/arm.c (arm_movmemqi_unaligned, arm_gen_movmemqi,
gen_movmem_ldrd_strd, thumb_expand_movmemqi) Change movmem to cpymem.
* config/arm/arm.md (movmemqi): Change movmem to cpymem.
* config/arm/thumb1.md (movmem12b, movmem8b): Change movmem to cpymem.
* config/avr/avr-protos.h: Change movmem to cpymem.
* config/avr/avr.c (avr_adjust_insn_length, avr_emit_movmemhi,
avr_out_movmem): Change movmem to cpymem.
* config/avr/avr.md (movmemhi, movmem_<mode>, movmemx_<mode>):
Change movmem to cpymem.
* config/bfin/bfin-protos.h: Change movmem to cpymem.
* config/bfin/bfin.c (single_move_for_movmem, bfin_expand_movmem):
Change movmem to cpymem.
* config/bfin/bfin.h: Change movmem to cpymem in comment.
* config/bfin/bfin.md (movmemsi): Change name to cpymemsi.
* config/c6x/c6x-protos.h: Change movmem to cpymem.
* config/c6x/c6x.c (c6x_expand_movmem): Change movmem to cpymem.
* config/c6x/c6x.md (movmemsi): Change name to cpymemsi.
* config/frv/frv.md (movmemsi): Change name to cpymemsi.
* config/ft32/ft32.md (movmemsi): Change name to cpymemsi.
* config/h8300/h8300.md (movmemsi): Change name to cpymemsi.
* config/i386/i386-expand.c (expand_set_or_movmem_via_loop,
expand_set_or_movmem_via_rep, expand_movmem_epilogue,
expand_setmem_epilogue_via_loop, expand_set_or_cpymem_prologue,
expand_small_cpymem_or_setmem,
expand_set_or_cpymem_prologue_epilogue_by_misaligned_moves,
expand_set_or_cpymem_constant_prologue,
ix86_expand_set_or_cpymem): Change movmem to cpymem.
* config/i386/i386-protos.h: Change movmem to cpymem.
* config/i386/i386.h: Change movmem to cpymem in comment.
* config/i386/i386.md (movmem<mode>): Change name to cpymem.
(setmem<mode>): Change expansion function name.
* config/lm32/lm32.md (movmemsi): Change name to cpymemsi.
* config/m32c/blkmov.md (movmemhi, movmemhi_bhi_op, movmemhi_bpsi_op,
movmemhi_whi_op, movmemhi_wpsi_op): Change movmem to cpymem.
* config/m32c/m32c-protos.h: Change movmem to cpymem.
* config/m32c/m32c.c (m32c_expand_movmemhi): Change movmem to cpymem.
* config/m32r/m32r.c (m32r_expand_block_move): Change movmem to cpymem.
* config/m32r/m32r.md (movmemsi, movmemsi_internal): Change movmem
to cpymem.
* config/mcore/mcore.md (movmemsi): Change name to cpymemsi.
* config/microblaze/microblaze.c: Change movmem to cpymem in comment.
* config/microblaze/microblaze.md (movmemsi): Change name to cpymemsi.
* config/mips/mips.c (mips_use_by_pieces_infrastructure_p):
Change movmem to cpymem.
* config/mips/mips.h: Change movmem to cpymem.
* config/mips/mips.md (movmemsi): Change name to cpymemsi.
* config/nds32/nds32-memory-manipulation.c
(nds32_expand_movmemsi_loop_unknown_size,
nds32_expand_movmemsi_loop_known_size, nds32_expand_movmemsi_loop,
nds32_expand_movmemsi_unroll,
nds32_expand_movmemsi): Change movmem to cpymem.
* config/nds32/nds32-multiple.md (movmemsi): Change name to cpymemsi.
* config/nds32/nds32-protos.h: Change movmem to cpymem.
* config/pa/pa.c (compute_movmem_length): Change movmem to cpymem.
(pa_adjust_insn_length): Change call to compute_movmem_length.
* config/pa/pa.md (movmemsi, movmemsi_prereload, movmemsi_postreload,
movmemdi, movmemdi_prereload,
movmemdi_postreload): Change movmem to cpymem.
* config/pdp11/pdp11.md (movmemhi, movmemhi1,
movmemhi_nocc, UNSPEC_MOVMEM): Change movmem to cpymem.
* config/riscv/riscv.c: Change movmem to cpymem in comment.
* config/riscv/riscv.h: Change movmem to cpymem.
* config/riscv/riscv.md: (movmemsi) Change name to cpymemsi.
* config/rs6000/rs6000.md: (movmemsi) Change name to cpymemsi.
* config/rx/rx.md: (UNSPEC_MOVMEM, movmemsi, rx_movmem): Change
movmem to cpymem.
* config/s390/s390-protos.h: Change movmem to cpymem.
* config/s390/s390.c (s390_expand_movmem, s390_expand_setmem,
s390_expand_insv): Change movmem to cpymem.
* config/s390/s390.md (movmem<mode>, movmem_short, *movmem_short,
movmem_long, *movmem_long, *movmem_long_31z): Change movmem to cpymem.
* config/sh/sh.md (movmemsi): Change name to cpymemsi.
* config/sparc/sparc.h: Change movmem to cpymem in comment.
* config/vax/vax-protos.h (vax_output_movmemsi): Remove prototype
for nonexistent function.
* config/vax/vax.h: Change movmem to cpymem in comment.
* config/vax/vax.md (movmemhi, movmemhi1): Change movmem to cpymem.
* config/visium/visium.h: Change movmem to cpymem in comment.
* config/visium/visium.md (movmemsi): Change name to cpymemsi.
* config/xtensa/xtensa.md (movmemsi): Change name to cpymemsi.
* doc/md.texi: Change movmem to cpymem and update description to match.
* doc/rtl.texi: Change movmem to cpymem.
* target.def (use_by_pieces_infrastructure_p): Change movmem to cpymem.
* doc/tm.texi: Regenerate.
From-SVN: r272755
Bill Schmidt [Thu, 27 Jun 2019 13:59:20 +0000 (13:59 +0000)]
rs6000.c (rs6000_option_override_internal): Enable -fvariable-expansion-in-unroller by default.
2019-06-27 Bill Schmidt <wschmidt@linux.ibm.com>
* config/rs6000/rs6000.c (rs6000_option_override_internal): Enable
-fvariable-expansion-in-unroller by default.
* doc/invoke.texi (-fvariable-expansion-in-unroller): Document new
default for Power.
From-SVN: r272754
David Edelsohn [Thu, 27 Jun 2019 13:33:45 +0000 (13:33 +0000)]
revert: config.gcc (powerpc-ibm-aix*): Define target_gtfiles.
Revert
2019-06-26 David Edelsohn <dje.gcc@gmail.com>
* config.gcc (powerpc-ibm-aix*): Define target_gtfiles.
* config.gcc(rs6000-*-*): Define target_gtfiles.
From-SVN: r272753
Jan Hubicka [Thu, 27 Jun 2019 12:08:12 +0000 (12:08 +0000)]
lto-common.c: tree-pretty-print.h
* lto-common.c: tree-pretty-print.h
(type_streaming_finished): New static var.
(gimple_register_canonical_type_1): Return updated hash; handle ODR
types.
(iterative_hash_canonical_type): Update use of
gimple_register_canonical_type_1.
From-SVN: r272750
Jan Hubicka [Thu, 27 Jun 2019 12:07:43 +0000 (14:07 +0200)]
class.c (layout_class_type): Set TYPE_CXX_ODR_P for as-base type copy.
* class.c (layout_class_type): Set TYPE_CXX_ODR_P for as-base
type copy.
* ipa-devirt.c (odr_type_d): Add tbaa_enabled flag.
(add_type_duplicate): When odr hash is not allocated, to nothing.
(odr_based_tbaa_p): New function.
(set_type_canonical_for_odr_type): New function.
* ipa-utils.h (enable_odr_based_tbaa, odr_based_tbaa_p,
set_type_canonical_for_odr_type): New.
* tree.c (gimple_canonical_types_compatible_p): ODR types with
ODR based TBAA are not equivalent to non-ODR types.
* lto-common.c: Include demangle.h and tree-pretty-print.h
(type_streaming_finished): New static var.
(gimple_register_canonical_type_1): Return updated hash; handle ODR
types.
(iterative_hash_canonical_type): Update use of
gimple_register_canonical_type_1.
* g++.dg/lto/alias-2_0.C: New testcase.
* g++.dg/lto/alias-2_1.C: New testcase.
From-SVN: r272749
Martin Liska [Thu, 27 Jun 2019 11:22:36 +0000 (13:22 +0200)]
Fix various issues seen with clang-static-analyzer.
2019-06-27 Martin Liska <mliska@suse.cz>
PR tree-optimization/90974
PR rtl-optimization/90975
PR rtl-optimization/90976
PR target/91016
PR tree-optimization/91017
* config/i386/i386-expand.c (ix86_expand_rounddf_32): Remove
unused tmp.
* lra.c (lra_set_insn_recog_data): Remove a leftover from
initial commit of IRA.
* optabs.c (expand_twoval_binop): Use xop0 and xop1 instead
of op0 and op1.
* tree-vect-loop.c (vect_create_epilog_for_reduction):
Remove unused mode1.
* tree-vect-stmts.c (vectorizable_call): Remove dead assignment
to new_stmt_info.
From-SVN: r272746
Jakub Jelinek [Thu, 27 Jun 2019 11:13:10 +0000 (13:13 +0200)]
re PR target/90991 (_mm_loadu_ps instrinsic translates to vmovaps in combination with _mm512_insertf32x4)
PR target/90991
* config/i386/sse.md (avx_vec_concat<mode>): Use nonimmediate_operand
instead of register_operand for operands[1], add m to its constraints
if operands[2] uses "C" constraint. Ensure in condition that if
operands[2] is not 0, then operands[1] is not a MEM. For last two
alternatives, use unaligned loads instead of aligned if operands[1] is
misaligned_operand.
* gcc.target/i386/avx2-pr90991-1.c: New test.
* gcc.target/i386/avx512dq-pr90991-2.c: New test.
From-SVN: r272745
Martin Liska [Thu, 27 Jun 2019 10:25:21 +0000 (12:25 +0200)]
Remove quite obvious dead assignments.
2019-06-27 Martin Liska <mliska@suse.cz>
* asan.c (asan_emit_allocas_unpoison): Remove obviously
dead assignments.
* bt-load.c (move_btr_def): Likewise.
* builtins.c (expand_builtin_apply_args_1): Likewise.
(expand_builtin_apply): Likewise.
* cfgexpand.c (expand_asm_stmt): Likewise.
(construct_init_block): Likewise.
* cfghooks.c (verify_flow_info): Likewise.
* cfgloopmanip.c (remove_path): Likewise.
* cfgrtl.c (rtl_verify_bb_layout): Likewise.
* cgraph.c (cgraph_node::set_pure_flag): Likewise.
* combine.c (simplify_if_then_else): Likewise.
* config/i386/i386.c (ix86_setup_incoming_vararg_bounds): Likewise.
(choose_basereg): Likewise.
(ix86_expand_prologue): Likewise.
(ix86_preferred_output_reload_class): Likewise.
* cselib.c (cselib_record_sets): Likewise.
* df-scan.c (df_scan_alloc): Likewise.
* dojump.c (do_jump_by_parts_greater_rtx): Likewise.
* early-remat.c (early_remat::record_equiv_candidates): Likewise.
* emit-rtl.c (try_split): Likewise.
* graphite-scop-detection.c (assign_parameter_index_in_region): Likewise.
* ipa-cp.c (cgraph_edge_brings_all_agg_vals_for_node): Likewise.
* ira-color.c (setup_profitable_hard_regs): Likewise.
* ira.c (rtx_moveable_p): Likewise.
* lra-eliminations.c (eliminate_regs_in_insn): Likewise.
* read-rtl.c (read_subst_mapping): Likewise.
* regrename.c (scan_rtx): Likewise.
* reorg.c (fill_slots_from_thread): Likewise.
* tree-inline.c (tree_function_versioning): Likewise.
* tree-ssa-reassoc.c (optimize_ops_list): Likewise.
* tree-ssa-sink.c (statement_sink_location): Likewise.
* tree-ssa-threadedge.c (thread_across_edge): Likewise.
* tree-vect-loop.c (vect_get_loop_niters): Likewise.
(vect_create_epilog_for_reduction): Likewise.
* tree.c (build_nonstandard_integer_type): Likewise.
2019-06-27 Martin Liska <mliska@suse.cz>
* class.c (adjust_clone_args): Remove obviously
dead assignments.
(dump_class_hierarchy_r): Likewise.
* decl.c (check_initializer): Likewise.
* parser.c (cp_parser_lambda_expression): Likewise.
* pt.c (unify_bound_ttp_args): Likewise.
(convert_template_argument): Likewise.
* rtti.c (build_headof): Likewise.
* typeck.c (convert_for_initialization): Likewise.
2019-06-27 Martin Liska <mliska@suse.cz>
* libgcov-driver-system.c (gcov_exit_open_gcda_file): Remove obviously
dead assignments.
* libgcov-util.c: Likewise.
From-SVN: r272744
Jan Beulich [Thu, 27 Jun 2019 10:19:37 +0000 (10:19 +0000)]
ix86: pass correct options to compiler for gfni-4 testcase
SSE2 is the required prereq of the builtins; as x86-64 has SSE2 enabled
anyway, the test failure was noticable on 32-bit builds only.
From-SVN: r272743
Richard Biener [Thu, 27 Jun 2019 10:11:57 +0000 (10:11 +0000)]
tree-ssa-sccvn.c (vn_reference_lookup_3): Encode valueized RHS.
2019-06-27 Richard Biener <rguenther@suse.de>
* tree-ssa-sccvn.c (vn_reference_lookup_3): Encode valueized RHS.
* gcc.dg/tree-ssa/ssa-fre-69.c: New testcase.
From-SVN: r272742
Jun Ma [Thu, 27 Jun 2019 09:50:35 +0000 (09:50 +0000)]
re PR tree-optimization/89772 (memchr for a character not in constant nul-padded string not folded)
PR tree-optimization/89772
* gimple-fold.c (gimple_fold_builtin_memchr): consider trailing nuls in
out-of-bound accesses checking.
gcc/testsuite
* gcc.dg/builtin-memchr-4.c: New test.
From-SVN: r272740
Jonathan Wakely [Thu, 27 Jun 2019 09:42:39 +0000 (10:42 +0100)]
PR libstdc++/91012 fixfilesystem_error::what() string
When I refactored the filesystem_error code I changed it to only use the
constructor parameter in the what() string, instead of the string
returned by system_error::what(). That meant it no longer included the
description of the error_code that system_error adds. This restores the
previous behaivour, as encouraged by the standard ("Implementations
should include the system_error::what() string and the pathnames of
path1 and path2 in the native format in the returned string").
PR libstdc++/91012
* src/c++17/fs_path.cc (filesystem_error::_Impl): Use a string_view
for the what_arg parameters.
(filesystem_error::filesystem_error): Pass system_error::what() to
the _Impl constructor.
* testsuite/27_io/filesystem/filesystem_error/cons.cc: Ensure that
filesystem_error::what() contains system_error::what().
From-SVN: r272739
Martin Liska [Thu, 27 Jun 2019 09:41:34 +0000 (11:41 +0200)]
Fix ICE when __builtin_calloc has no LHS (PR tree-optimization/91014).
2019-06-27 Martin Liska <mliska@suse.cz>
PR tree-optimization/91014
* tree-ssa-dse.c (initialize_ao_ref_for_dse): Bail out
when LHS is NULL_TREE.
2019-06-27 Martin Liska <mliska@suse.cz>
PR tree-optimization/91014
* gcc.target/s390/pr91014.c: New test.
From-SVN: r272738
Richard Biener [Thu, 27 Jun 2019 09:08:02 +0000 (09:08 +0000)]
re PR testsuite/91004 (Excess errors in g++.dg/torture/pr34850.C starting with r272688)
2019-06-27 Richard Biener <rguenther@suse.de>
PR testsuite/91004
* g++.dg/torture/pr34850.C: Fix overly reduced testcase.
From-SVN: r272737
Martin Liska [Thu, 27 Jun 2019 08:21:47 +0000 (10:21 +0200)]
Fix warnings seen by clang in gcc/symbol-summary.h.
2019-06-27 Martin Liska <mliska@suse.cz>
* symbol-summary.h (traverse): Pass
argument a to the call of callback.
(gt_ggc_mx): Mark arguments as unused.
(gt_pch_nx): Likewise.
From-SVN: r272734
Martin Liska [Thu, 27 Jun 2019 08:21:32 +0000 (10:21 +0200)]
Fix misc stuff seen by clang-static-analyzer.
2019-06-27 Martin Liska <mliska@suse.cz>
* lto-dump.c (struct symbol_entry): Add default dtor.
(struct variable_entry): Likewise.
(struct function_entry): Likewise.
(dump_list_functions): Release memory.
(dump_list_variables): Likewise.
2019-06-27 Martin Liska <mliska@suse.cz>
* libgcov-util.c (gcov_profile_merge): Release allocated
memory.
(calculate_overlap): Likewise.
From-SVN: r272733
Kewen Lin [Thu, 27 Jun 2019 05:33:15 +0000 (05:33 +0000)]
One line change onto r272731
PR target/62147
* gcc/loop-iv.c (find_simple_exit)
- if (single_exit (loop) && finite_loop_p (loop))
+ if (desc->infinite && single_exit (loop) && finite_loop_p (loop))
From-SVN: r272732
Kewen Lin [Thu, 27 Jun 2019 05:24:00 +0000 (05:24 +0000)]
Call finite_loop_p in RTL to get better finiteness information.
gcc/ChangeLog
2019-06-27 Kewen Lin <linkw@gcc.gnu.org>
PR target/62147
* gcc/loop-iv.c (find_simple_exit): Call finite_loop_p to update finiteness.
gcc/testsuite/ChangeLog
2019-06-27 Kewen Lin <linkw@gcc.gnu.org>
PR target/62147
* gcc.target/powerpc/pr62147.c: New test.
From-SVN: r272731
Jeff Law [Thu, 27 Jun 2019 02:42:30 +0000 (20:42 -0600)]
re PR tree-optimization/90883 (Generated code is worse if returned struct is unnamed)
PR tree-optimization/90883
* tree-ssa-dse.c (delete_dead_or_redundant_call): Fix signature.
(delete_dead_or_redundant_assignment): Likewise.
From-SVN: r272726
Jeff Law [Thu, 27 Jun 2019 02:41:27 +0000 (20:41 -0600)]
re PR tree-optimization/90883 (Generated code is worse if returned struct is unnamed)
PR tree-optimization/90883
* tree-ssa-dse.c (delete_dead_or_redundant_call): Fix signature.
(delete_dead_or_redundant_assignment): Likewise.
From-SVN: r272725
GCC Administrator [Thu, 27 Jun 2019 00:16:22 +0000 (00:16 +0000)]
Daily bump.
From-SVN: r272723
Jonathan Wakely [Wed, 26 Jun 2019 22:54:38 +0000 (23:54 +0100)]
Define std::chars_format enumeration type
This type isn't used anywhere yet, but will be needed for the
floating-point overloads of to_chars and from_chars.
* include/std/charconv (chars_format): Define bitmask type.
* testsuite/20_util/to_chars/chars_format.cc: New test.
From-SVN: r272718
Jeff Law [Wed, 26 Jun 2019 21:36:27 +0000 (15:36 -0600)]
re PR tree-optimization/90883 (Generated code is worse if returned struct is unnamed)
PR tree-optimization/90883
* tree-ssa-alias.c (stmt_kills_ref_p): Handle BUILT_IN_CALLOC.
* tree-ssa-dse.c: Update various comments to distinguish between
dead and redundant stores.
(initialize_ao_ref_for_dse): Handle BUILT_IN_CALLOC.
(dse_optimize_redundant_stores): New function.
(delete_dead_or_redundant_call): Renamed from delete_dead_call.
Distinguish between dead and redundant calls in dump output. All
callers updated.
(delete_dead_or_redundant_assignment): Similarly for assignments.
(dse_optimize_stmt): Handle _CHK variants. For statements which
store 0 into multiple memory locations, try to prove a subsequent
store is redundant.
PR tree-optimization/90883
* g++.dg/tree-ssa/pr90883.C: New test.
* gcc.dg/tree-ssa/ssa-dse-36.c: New test.
From-SVN: r272717
Uros Bizjak [Wed, 26 Jun 2019 19:12:27 +0000 (21:12 +0200)]
re PR target/89021 (Implement mmintrin.h in SSE)
PR target/89021
* config/i386/i386.c (ix86_autovectorize_vector_sizes):
Autovectorize 8-byte vectors for TARGET_MMX_WITH_SSE.
testsuite/ChangeLog:
PR target/89021
* lib/target-supports.exp (available_vector_sizes)
<[istarget i?86-*-*] || [istarget x86_64-*-*]>: Add
64-bit vectors for !ia32.
From-SVN: r272711
Iain Sandoe [Wed, 26 Jun 2019 19:04:50 +0000 (19:04 +0000)]
[PATCH, PPC 2/2] Fix Darwin bootstrap after split of rs6000.c.
To fix this we need to make the branch islands (or code) visible between
both files. This keeps the generation side in rs6000.c and moves the
output routine to rs6000-logue.c, placing a reference to the islands
vector in rs6000-internal.h.
2019-06-26 Iain Sandoe <iain@sandoe.co.uk>
* config/rs6000/rs6000-internal.h (branch_island): New typedef.
(branch_islands): New extern.
* config/rs6000/rs6000-logue.c (macho_branch_islands): Moved from
* config/rs6000/rs6000.c: .. here.
From-SVN: r272710
Iain Sandoe [Wed, 26 Jun 2019 19:00:16 +0000 (19:00 +0000)]
[PATCH, PPC 1/2] Make sure the gt- files are built for all sub-targets.
The new gt-rs6000-logue.h is common to all sub-targets in the port, so
it needs to be added for them.
It seems better to place the common target_gtfiles in the powerpc*-*-*
section, rather than duplicating them in sub-targets. This would make it
less likely that a sub-target would be overlooked in any future file
introductions.
2019-06-26 Iain Sandoe <iain@sandoe.co.uk>
* config.gcc (powerpc*-*-linux*): Move target_gtfiles from here..
(powerpc*-*-*) ... to here.
From-SVN: r272708
Jeff Law [Wed, 26 Jun 2019 18:00:00 +0000 (12:00 -0600)]
tree-ssa-dse.c (initialize_ao_ref_for_dse): Handle _chk variants of memcpy, memmove and memset builtins.
* tree-ssa-dse.c (initialize_ao_ref_for_dse): Handle _chk variants of
memcpy, memmove and memset builtins.
(maybe_trim_memstar_call): Likewise.
* gcc.c-torture/execute/builtins/builtins.exp: Add -fno-tree-dse
as DSE compromises several of these tests.
* gcc.dg/builtin-stringop-chk-1.c: Similarly.
* gcc.dg/memcpy-2.c: Similarly.
* gcc.dg/pr40340-1.c: Similarly.
* gcc.dg/pr40340-2.c: Similarly.
* gcc.dg/pr40340-5.c: Similarly.
From-SVN: r272704
Steven G. Kargl [Wed, 26 Jun 2019 16:16:58 +0000 (16:16 +0000)]
ChangeLog: Document revision 272698
2016-06-26 Steven G. Kargl <kargl@gcc.gnu.org>
* ChangeLog: Document revision 272698
2016-06-26 Steven G. Kargl <kargl@gcc.gnu.org>
* testsuite/ChangeLog: Document revision 272698
From-SVN: r272699
Jonathan Wakely [Wed, 26 Jun 2019 14:38:23 +0000 (15:38 +0100)]
Add new helper traits for signed/unsigned integer types
Reuse the __is_one_of alias in additional places, and define traits to
check for signed/unsigned integer types so we don't have to duplicate
those checks elsewhere.
The additional overloads for std::byte in <bit> were reviewed by LEWG
and considered undesirable, so this patch removes them.
* include/bits/fs_path.h (path::__is_encoded_char): Use __is_one_of.
* include/std/bit (_If_is_unsigned_integer_type): Remove.
(_If_is_unsigned_integer): Use __is_unsigned_integer.
(rotl(byte, unsigned), rotr(byte, unsigned), countl_zero(byte))
(countl_one(byte), countr_zero(byte), countr_one(byte))
(popcount(byte), ispow2(byte), ceil2(byte), floor2(byte))
(log2p1(byte)): Remove.
* include/std/charconv (__detail::__is_one_of): Move to <type_traits>.
(__detail::__is_int_to_chars_type): Remove.
(__detail::__integer_to_chars_result_type): Use __is_signed_integer
and __is_unsigned_integer.
* include/std/type_traits (__is_one_of): Move here from <charconv>.
(__is_signed_integer, __is_unsigned_integer): New helpers.
* testsuite/26_numerics/bit/bit.pow.two/ceil2.cc: Remove test for
std::byte overload.
* testsuite/26_numerics/bit/bit.pow.two/floor2.cc: Likewise.
* testsuite/26_numerics/bit/bit.pow.two/ispow2.cc: Likewise.
* testsuite/26_numerics/bit/bit.pow.two/log2p1.cc: Likewise.
* testsuite/26_numerics/bit/bitops.count/countl_one.cc: Likewise.
* testsuite/26_numerics/bit/bitops.count/countl_zero.cc: Likewise.
* testsuite/26_numerics/bit/bitops.count/countr_one.cc: Likewise.
* testsuite/26_numerics/bit/bitops.count/countr_zero.cc: Likewise.
* testsuite/26_numerics/bit/bitops.count/popcount.cc: Likewise.
* testsuite/26_numerics/bit/bitops.rot/rotl.cc: Likewise.
* testsuite/26_numerics/bit/bitops.rot/rotr.cc: Likewise.
From-SVN: r272695
David Edelsohn [Wed, 26 Jun 2019 13:46:01 +0000 (13:46 +0000)]
* config/rs6000/rs6000-logue.c: Add #ifndef TARGET_PROFILE_KERNEL.
From-SVN: r272694
David Edelsohn [Wed, 26 Jun 2019 13:36:23 +0000 (13:36 +0000)]
* config.gcc (powerpc-ibm-aix*): Define target_gtfiles.
From-SVN: r272693
Nathan Sidwell [Wed, 26 Jun 2019 12:58:39 +0000 (12:58 +0000)]
[PR preprocessor/90927] Fixe dependency output
https://gcc.gnu.org/ml/gcc-patches/2019-06/msg01664.html
libcpp/
PR preprocessor/90927
* mkdeps.c (mkdeps::vec::operator[]): Add non-const variant.
(deps_add_target): Deal with out of order unquoted targets.
gcc/testsuite/
* c-c++-common/pr90927.c: New.
From-SVN: r272692
Segher Boessenkool [Wed, 26 Jun 2019 12:16:40 +0000 (14:16 +0200)]
rs6000: Fix rs6000_keep_leaf_when_profiled
This function is called from elsewhere, so shouldn't be static.
* config/rs6000/rs6000-internal.h (rs6000_keep_leaf_when_profiled): New
declaration.
* config/rs6000/rs6000-logue.c (rs6000_keep_leaf_when_profiled): Remove
"static".
* config/rs6000/rs6000.c (rs6000_keep_leaf_when_profiled): Delete
declaration.
---
gcc/config/rs6000/rs6000-internal.h | 1 +
gcc/config/rs6000/rs6000-logue.c | 4 ++--
gcc/config/rs6000/rs6000.c | 1 -
3 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/gcc/config/rs6000/rs6000-internal.h b/gcc/config/rs6000/rs6000-internal.h
index a1acb66..22ebd37 100644
--- a/gcc/config/rs6000/rs6000-internal.h
+++ b/gcc/config/rs6000/rs6000-internal.h
@@ -99,6 +99,7 @@ extern bool save_reg_p (int reg);
extern const char * rs6000_machine_from_flags (void);
extern void emit_asm_machine (void);
extern bool rs6000_global_entry_point_prologue_needed_p (void);
+extern bool rs6000_keep_leaf_when_profiled (void);
/* Return true if the OFFSET is valid for the quad address instructions that
use d-form (register + offset) addressing. */
diff --git a/gcc/config/rs6000/rs6000-logue.c b/gcc/config/rs6000/rs6000-logue.c
index 9df4b5a..adc137b 100644
--- a/gcc/config/rs6000/rs6000-logue.c
+++ b/gcc/config/rs6000/rs6000-logue.c
@@ -4025,8 +4025,8 @@ rs6000_output_function_prologue (FILE *file)
/* -mprofile-kernel code calls mcount before the function prolog,
so a profiled leaf function should stay a leaf function. */
-static bool
-rs6000_keep_leaf_when_profiled ()
+bool
+rs6000_keep_leaf_when_profiled (void)
{
return TARGET_PROFILE_KERNEL;
}
diff --git a/gcc/config/rs6000/rs6000.c b/gcc/config/rs6000/rs6000.c
index 3fc4029..bcfc881 100644
--- a/gcc/config/rs6000/rs6000.c
+++ b/gcc/config/rs6000/rs6000.c
@@ -1338,7 +1338,6 @@ static bool rs6000_secondary_reload_move (enum rs6000_reg_type,
secondary_reload_info *,
bool);
rtl_opt_pass *make_pass_analyze_swaps (gcc::context*);
-static bool rs6000_keep_leaf_when_profiled () __attribute__ ((unused));
static tree rs6000_fold_builtin (tree, int, tree *, bool);
/* Hash table stuff for keeping track of TOC entries. */
--
1.8.3.1
From-SVN: r272691
Segher Boessenkool [Wed, 26 Jun 2019 12:14:37 +0000 (14:14 +0200)]
rs6000: Remove duplicated code
A large portion of the code moved from rs6000.c (to rs6000-logue.c)
was accidentally retained. This fixes it.
* rs6000.c: Fix previous commit, it missed some changes.
From-SVN: r272690
Richard Biener [Wed, 26 Jun 2019 11:16:56 +0000 (11:16 +0000)]
re PR middle-end/90982 (ICE in make_decl_rtl, at varasm.c:1344)
2019-06-26 Richard Biener <rguenther@suse.de>
PR ipa/90982
* tree-inline.c (remap_ssa_name): Copy SSA range info.
* g++.dg/torture/pr90982.C: New testcase.
From-SVN: r272688
Richard Biener [Wed, 26 Jun 2019 11:09:51 +0000 (11:09 +0000)]
lto-streamer.h (lto_bitmap_alloc): Remove.
2019-06-26 Richard Biener <rguenther@suse.de>
* lto-streamer.h (lto_bitmap_alloc): Remove.
(lto_bitmap_free): Likewise.
* lto-streamer.c (lto_bitmap_alloc): Remove.
(lto_bitmap_free): Likewise.
(lto_obstack): Likewise.
(lto_obstack_initialized): Likewise.
* lto-streamer-out.c (lto_output): Use own obstack for local
bitmap, free it consistently.
From-SVN: r272687
Rainer Orth [Wed, 26 Jun 2019 10:43:08 +0000 (10:43 +0000)]
Fix sanitizer_common/sanitizer_posix_libcdep.cc compilation on Solaris 11.5
* sanitizer_common/sanitizer_posix_libcdep.cc: Cherry-pick
compiler-rt revision 363778.
From-SVN: r272685
Paolo Carlini [Wed, 26 Jun 2019 08:51:50 +0000 (08:51 +0000)]
re PR c++/67184 (Missed optimization with C++11 final specifier)
2019-06-26 Paolo Carlini <paolo.carlini@oracle.com>
PR c++/67184
PR c++/69445
* g++.dg/other/final3.C: New.
* g++.dg/other/final5.C: Likewise.
From-SVN: r272675
Jakub Jelinek [Wed, 26 Jun 2019 08:26:18 +0000 (10:26 +0200)]
re PR target/90991 (_mm_loadu_ps instrinsic translates to vmovaps in combination with _mm512_insertf32x4)
PR target/90991
* config/i386/sse.md
(*<extract_type>_vinsert<shuffletype><extract_suf>_0): Use vmovupd,
vmovups, vmovdqu, vmovdqu32 or vmovdqu64 instead of the aligned
insns if operands[2] is misaligned_operand.
* gcc.target/i386/avx512dq-pr90991-1.c: New test.
From-SVN: r272674
Li Jia He [Wed, 26 Jun 2019 08:23:06 +0000 (08:23 +0000)]
[RS6000] Change maddld match_operand from DI to GPR
From PowerPC ISA3.0, the description of `maddld RT, RA.RB, RC` is as follows:
64-bit RA and RB are multiplied and then the RC is signed extend to 128 bits,
and add them together.
We only apply it to 64-bit mode (DI) when implementing maddld. However, if we
can guarantee that the result of the maddld operation will be limited to 32-bit
mode (SI), we can still apply it to 32-bit mode (SI).
gcc/ChangeLog
2019-06-26 Li Jia He <helijia@linux.ibm.com>
* config/rs6000/rs6000.h (TARGET_MADDLD): Remove the restriction of
TARGET_POWERPC64.
* config/rs6000/rs6000.md (maddld): Change maddld match_operand from DI
to GPR.
gcc/testsuite/ChangeLog
2019-06-26 Li Jia He <helijia@linux.ibm.com>
* gcc.target/powerpc/maddld-1.c: New testcase.
From-SVN: r272673
Segher Boessenkool [Wed, 26 Jun 2019 07:43:52 +0000 (09:43 +0200)]
doc: Fix opindex for -W options
@opindex -Wxxx is wrong; it should be @opindex Wxxx.
* doc/invoke.texi (Warning Options): Fix some @opindex syntax.
From-SVN: r272672
Martin Liska [Wed, 26 Jun 2019 06:44:58 +0000 (08:44 +0200)]
Fix one another thinko in tree-vect-loop.c (PR tree-optimization/90973).
2019-06-26 Martin Liska <mliska@suse.cz>
PR tree-optimization/90973
* tree-vect-loop.c (vect_get_known_peeling_cost): Use
epilogue_cost_vec instead of prologue_cost_vec for
a epilogue cost.
From-SVN: r272671
Martin Liska [Wed, 26 Jun 2019 06:44:28 +0000 (08:44 +0200)]
Fix missing else keyword seen with clang-static-analyzer:
2019-06-26 Martin Liska <mliska@suse.cz>
* bb-reorder.c (connect_better_edge_p): Add missing else
statement in the middle of if-else statements.
/home/marxin/Programming/gcc/gcc/bb-reorder.c:1031:2: warning: Value stored to 'is_better_edge' is never read
is_better_edge = true;
^ ~~~~
/home/marxin/Programming/gcc/gcc/bb-reorder.c:1034:2: warning: Value stored to 'is_better_edge' is never read
is_better_edge = false;
^ ~~~~~
From-SVN: r272670
Jason Merrill [Wed, 26 Jun 2019 04:56:07 +0000 (00:56 -0400)]
PR c++/70462 - unnecessary base ctor variant with final.
As pointed out in the PR, we don't need base 'tor variants for a final
class, since it can never be a base. I tried also dropping complete
variants for abstract classes, but that runs into ABI compatibility problems
with older releases that refer to those symbols.
* optimize.c (populate_clone_array): Skip base variant if
CLASSTYPE_FINAL.
(maybe_clone_body): We don't need an alias if we are only defining
one clone.
From-SVN: r272669
projects / platform / upstream / gcc.git / log