FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] New unit GNAT.Sets

Browse source 
This patch implements unit GNAT.Sets which currently offers a general purpose
membership set. The patch also streamlines GNAT.Dynamic_HTables and GNAT.Lists
to use parts of the same API, types, and exceptions as those used by GNAT.Sets.

2018-09-26  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* gcc-interface/Make-lang.in: Add unit GNAT.Sets to the list of
	front end sources.
	* impunit.adb: Add unit GNAT.Sets to the list of predefined
	units.
	* Makefile.rtl: Add unit GNAT.Sets to the list of non-tasking
	units.
	* libgnat/g-sets.adb: New unit.
	* libgnat/g-sets.ads: New unit.
	* libgnat/g-dynhta.adb (Minimum_Size): Decrease to 8 in order to
	allow for small sets.  Update all occurrences of Table_Locked to
	Iterated.
	(Ensure_Unlocked): Query the number of iterators.
	(Find_Node): Use the supplied equality.
	(Is_Empty): New routine.
	(Lock): Update the number of iterators.
	(Prepend_Or_Replace): Use the supplied equality.
	(Size): Update the return type.
	(Unlock): Update the number of iterators.
	* libgnat/g-dynhta.ads: Update all occurrences of Table_Locked
	to Iterated.  Rename formal subprogram Equivalent_Keys to "=".
	(Bucket_Range_Type, Pair_Count_Type): Remove types.
	(Not_Created, Table_Locked, Iterator_Exhausted): Remove
	exceptions.
	(Hash_Table): Update to store the number of iterators rather
	than locks.
	(Is_Empty): New routine.
	(Size): Update the return type.
	* libgnat/g-lists.adb: Update all occurrences of List_Locked to
	Iterated.
	(Ensure_Unlocked): Query the number of iterators.
	(Length): Remove.
	(Lock): Update the number of iterators.
	(Size): New routine.
	(Unlock): Update the number of iterators.
	* libgnat/g-lists.ads: Update all occurrences of List_Locked to
	Iterated.
	(Element_Count_Type): Remove type.
	(Not_Created, Table_Locked, Iterator_Exhausted): Remove
	exceptions.
	(Linked_List): Update type to store the number of iterators
	rather than locks.
	(Length): Remove.
	(Size): New routine.
	* libgnat/gnat.ads (Bucket_Range_Type): New type.
	(Iterated, Iterator_Exhausted, and Not_Created): New exceptions.

gcc/testsuite/

	* gnat.dg/sets1.adb: New testcase.
	* gnat.dg/dynhash.adb, gnat.dg/linkedlist.adb: Update testcases
	to new API.

From-SVN: r264620
This commit is contained in:
Hristian Kirtchev 2018-09-26 09:18:02 +00:00 • committed by Pierre-Marie de Rodat
parent fcf1dd74bc
commit f8bc3bcb5f
15 changed files with 1177 additions and 209 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
gcc/ada/ChangeLog
View file

@ -1,3 +1,51 @@
2018-09-26 Hristian Kirtchev <kirtchev@adacore.com>
* gcc-interface/Make-lang.in: Add unit GNAT.Sets to the list of
front end sources.
* impunit.adb: Add unit GNAT.Sets to the list of predefined
units.
* Makefile.rtl: Add unit GNAT.Sets to the list of non-tasking
units.
* libgnat/g-sets.adb: New unit.
* libgnat/g-sets.ads: New unit.
* libgnat/g-dynhta.adb (Minimum_Size): Decrease to 8 in order to
allow for small sets. Update all occurrences of Table_Locked to
Iterated.
(Ensure_Unlocked): Query the number of iterators.
(Find_Node): Use the supplied equality.
(Is_Empty): New routine.
(Lock): Update the number of iterators.
(Prepend_Or_Replace): Use the supplied equality.
(Size): Update the return type.
(Unlock): Update the number of iterators.
* libgnat/g-dynhta.ads: Update all occurrences of Table_Locked
to Iterated. Rename formal subprogram Equivalent_Keys to "=".
(Bucket_Range_Type, Pair_Count_Type): Remove types.
(Not_Created, Table_Locked, Iterator_Exhausted): Remove
exceptions.
(Hash_Table): Update to store the number of iterators rather
than locks.
(Is_Empty): New routine.
(Size): Update the return type.
* libgnat/g-lists.adb: Update all occurrences of List_Locked to
Iterated.
(Ensure_Unlocked): Query the number of iterators.
(Length): Remove.
(Lock): Update the number of iterators.
(Size): New routine.
(Unlock): Update the number of iterators.
* libgnat/g-lists.ads: Update all occurrences of List_Locked to
Iterated.
(Element_Count_Type): Remove type.
(Not_Created, Table_Locked, Iterator_Exhausted): Remove
exceptions.
(Linked_List): Update type to store the number of iterators
rather than locks.
(Length): Remove.
(Size): New routine.
* libgnat/gnat.ads (Bucket_Range_Type): New type.
(Iterated, Iterator_Exhausted, and Not_Created): New exceptions.
2018-09-26 Javier Miranda <miranda@adacore.com>
* checks.adb (Install_Null_Excluding_Check): Do not add

1
gcc/ada/Makefile.rtl
View file

@ -445,6 +445,7 @@ GNATRTL_NONTASKING_OBJS= \
g-sehash$(objext) \
g-sercom$(objext) \
g-sestin$(objext) \
g-sets$(objext) \
g-sha1$(objext) \
g-sha224$(objext) \
g-sha256$(objext) \

1
gcc/ada/gcc-interface/Make-lang.in
View file

@ -320,6 +320,7 @@ GNAT_ADA_OBJS = \
ada/libgnat/g-hesora.o \
ada/libgnat/g-htable.o \
ada/libgnat/g-lists.o \
ada/libgnat/g-sets.o \
ada/libgnat/g-spchge.o \
ada/libgnat/g-speche.o \
ada/libgnat/g-u3spch.o \

1
gcc/ada/impunit.adb
View file

@ -298,6 +298,7 @@ package body Impunit is
("g-semaph", F), -- GNAT.Semaphores
("g-sercom", F), -- GNAT.Serial_Communications
("g-sestin", F), -- GNAT.Secondary_Stack_Info
("g-sets ", F), -- GNAT.Sets
("g-sha1 ", F), -- GNAT.SHA1
("g-sha224", F), -- GNAT.SHA224
("g-sha256", F), -- GNAT.SHA256

42
gcc/ada/libgnat/g-dynhta.adb
View file

@ -369,7 +369,7 @@ package body GNAT.Dynamic_HTables is
--------------------
package body Dynamic_HTable is
Minimum_Size : constant Bucket_Range_Type := 32;
Minimum_Size : constant Bucket_Range_Type := 8;
-- Minimum size of the buckets
Safe_Compression_Size : constant Bucket_Range_Type :=
@ -401,8 +401,8 @@ package body GNAT.Dynamic_HTables is
procedure Ensure_Unlocked (T : Instance);
pragma Inline (Ensure_Unlocked);
-- Verify that hash table T is unlocked. Raise Table_Locked if this is
-- not the case.
-- Verify that hash table T is unlocked. Raise Iterated if this is not
-- the case.
function Find_Bucket
(Bkts : Bucket_Table_Ptr;
@ -472,9 +472,10 @@ package body GNAT.Dynamic_HTables is
-- Create --
------------
function Create (Initial_Size : Bucket_Range_Type) return Instance is
function Create (Initial_Size : Positive) return Instance is
Size : constant Bucket_Range_Type :=
Bucket_Range_Type'Max (Initial_Size, Minimum_Size);
Bucket_Range_Type'Max
(Bucket_Range_Type (Initial_Size), Minimum_Size);
-- Ensure that the buckets meet a minimum size
T : constant Instance := new Hash_Table;
@ -661,8 +662,8 @@ package body GNAT.Dynamic_HTables is
-- The hash table has at least one outstanding iterator
if T.Locked > 0 then
raise Table_Locked;
if T.Iterators > 0 then
raise Iterated;
end if;
end Ensure_Unlocked;
@ -697,7 +698,7 @@ package body GNAT.Dynamic_HTables is
Nod := Head.Next;
while Is_Valid (Nod, Head) loop
if Equivalent_Keys (Nod.Key, Key) then
if Nod.Key = Key then
return Nod;
end if;
@ -797,6 +798,17 @@ package body GNAT.Dynamic_HTables is
return Is_OK;
end Has_Next;
--------------
-- Is_Empty --
--------------
function Is_Empty (T : Instance) return Boolean is
begin
Ensure_Created (T);
return T.Pairs = 0;
end Is_Empty;
--------------
-- Is_Valid --
--------------
@ -880,7 +892,7 @@ package body GNAT.Dynamic_HTables is
-- The hash table may be locked multiple times if multiple iterators
-- are operating over it.
T.Locked := T.Locked + 1;
T.Iterators := T.Iterators + 1;
end Lock;
-----------------------
@ -1046,11 +1058,7 @@ package body GNAT.Dynamic_HTables is
-- Put --
---------
procedure Put
(T : Instance;
Key : Key_Type;
Value : Value_Type)
is
procedure Put (T : Instance; Key : Key_Type; Value : Value_Type) is
procedure Expand;
pragma Inline (Expand);
-- Determine whether hash table T requires expansion, and if so,
@ -1099,7 +1107,7 @@ package body GNAT.Dynamic_HTables is
Nod := Head.Next;
while Is_Valid (Nod, Head) loop
if Equivalent_Keys (Nod.Key, Key) then
if Nod.Key = Key then
Nod.Value := Value;
return;
end if;
@ -1172,7 +1180,7 @@ package body GNAT.Dynamic_HTables is
-- Size --
----------
function Size (T : Instance) return Pair_Count_Type is
function Size (T : Instance) return Natural is
begin
Ensure_Created (T);
@ -1188,7 +1196,7 @@ package body GNAT.Dynamic_HTables is
-- The hash table may be locked multiple times if multiple iterators
-- are operating over it.
T.Locked := T.Locked - 1;
T.Iterators := T.Iterators - 1;
end Unlock;
end Dynamic_HTable;

55
gcc/ada/libgnat/g-dynhta.ads
View file

@ -283,21 +283,11 @@ package GNAT.Dynamic_HTables is
--
-- The destruction of the table reclaims all storage occupied by it.
-- The following type denotes the underlying range of the hash table
-- buckets.
type Bucket_Range_Type is mod 2 ** 32;
-- The following type denotes the multiplicative factor used in expansion
-- and compression of the hash table.
subtype Factor_Type is Bucket_Range_Type range 2 .. 100;
-- The following type denotes the number of key-value pairs stored in the
-- hash table.
type Pair_Count_Type is range 0 .. 2 ** 31 - 1;
-- The following type denotes the threshold range used in expansion and
-- compression of the hash table.
@ -333,10 +323,9 @@ package GNAT.Dynamic_HTables is
-- that the size of the buckets will be halved once the load factor
-- drops below 0.5.
with function Equivalent_Keys
with function "="
(Left : Key_Type;
Right : Key_Type) return Boolean;
-- Determine whether two keys are equivalent
with function Hash (Key : Key_Type) return Bucket_Range_Type;
-- Map an arbitrary key into the range of buckets
@ -353,52 +342,44 @@ package GNAT.Dynamic_HTables is
type Instance is private;
Nil : constant Instance;
Not_Created : exception;
-- This exception is raised when the hash table has not been created by
-- routine Create, and an attempt is made to read or mutate its state.
Table_Locked : exception;
-- This exception is raised when the hash table is being iterated on,
-- and an attempt is made to mutate its state.
function Create (Initial_Size : Bucket_Range_Type) return Instance;
function Create (Initial_Size : Positive) return Instance;
-- Create a new table with bucket capacity Initial_Size. This routine
-- must be called at the start of a hash table's lifetime.
procedure Delete (T : Instance; Key : Key_Type);
-- Delete the value which corresponds to key Key from hash table T. The
-- routine has no effect if the value is not present in the hash table.
-- This action will raise Table_Locked if the hash table has outstanding
-- This action will raise Iterated if the hash table has outstanding
-- iterators. If the load factor drops below Compression_Threshold, the
-- size of the buckets is decreased by Copression_Factor.
procedure Destroy (T : in out Instance);
-- Destroy the contents of hash table T, rendering it unusable. This
-- routine must be called at the end of a hash table's lifetime. This
-- action will raise Table_Locked if the hash table has outstanding
-- action will raise Iterated if the hash table has outstanding
-- iterators.
function Get (T : Instance; Key : Key_Type) return Value_Type;
-- Obtain the value which corresponds to key Key from hash table T. If
-- the value does not exist, return No_Value.
procedure Put
(T : Instance;
Key : Key_Type;
Value : Value_Type);
function Is_Empty (T : Instance) return Boolean;
-- Determine whether hash table T is empty
procedure Put (T : Instance; Key : Key_Type; Value : Value_Type);
-- Associate value Value with key Key in hash table T. If the table
-- already contains a mapping of the same key to a previous value, the
-- previous value is overwritten. This action will raise Table_Locked
-- if the hash table has outstanding iterators. If the load factor goes
-- previous value is overwritten. This action will raise Iterated if
-- the hash table has outstanding iterators. If the load factor goes
-- over Expansion_Threshold, the size of the buckets is increased by
-- Expansion_Factor.
procedure Reset (T : Instance);
-- Destroy the contents of hash table T, and reset it to its initial
-- created state. This action will raise Table_Locked if the hash table
-- created state. This action will raise Iterated if the hash table
-- has outstanding iterators.
function Size (T : Instance) return Pair_Count_Type;
function Size (T : Instance) return Natural;
-- Obtain the number of key-value pairs in hash table T
-------------------------
@ -420,10 +401,6 @@ package GNAT.Dynamic_HTables is
type Iterator is private;
Iterator_Exhausted : exception;
-- This exception is raised when an iterator is exhausted and further
-- attempts to advance it are made by calling routine Next.
function Iterate (T : Instance) return Iterator;
-- Obtain an iterator over the keys of hash table T. This action locks
-- all mutation functionality of the associated hash table.
@ -433,9 +410,7 @@ package GNAT.Dynamic_HTables is
-- iterator has been exhausted, restore all mutation functionality of
-- the associated hash table.
procedure Next
(Iter : in out Iterator;
Key : out Key_Type);
procedure Next (Iter : in out Iterator; Key : out Key_Type);
-- Return the current key referenced by iterator Iter and advance to
-- the next available key. If the iterator has been exhausted and
-- further attempts are made to advance it, this routine restores
@ -487,10 +462,10 @@ package GNAT.Dynamic_HTables is
Initial_Size : Bucket_Range_Type := 0;
-- The initial size of the buckets as specified at creation time
Locked : Natural := 0;
Iterators : Natural := 0;
-- Number of outstanding iterators
Pairs : Pair_Count_Type := 0;
Pairs : Natural := 0;
-- Number of key-value pairs in the buckets
end record;

37
gcc/ada/libgnat/g-lists.adb
View file

@ -54,7 +54,7 @@ package body GNAT.Lists is
procedure Ensure_Unlocked (L : Instance);
pragma Inline (Ensure_Unlocked);
-- Verify that list L is unlocked. Raise List_Locked if this is not the
-- Verify that list L is unlocked. Raise Iterated if this is not the
-- case.
function Find_Node
@ -306,8 +306,8 @@ package body GNAT.Lists is
-- The list has at least one outstanding iterator
if L.Locked > 0 then
raise List_Locked;
if L.Iterators > 0 then
raise Iterated;
end if;
end Ensure_Unlocked;
@ -514,17 +514,6 @@ package body GNAT.Lists is
return L.Nodes.Prev.Elem;
end Last;
------------
-- Length --
------------
function Length (L : Instance) return Element_Count_Type is
begin
Ensure_Created (L);
return L.Elements;
end Length;
----------
-- Lock --
----------
@ -536,17 +525,14 @@ package body GNAT.Lists is
-- The list may be locked multiple times if multiple iterators are
-- operating over it.
L.Locked := L.Locked + 1;
L.Iterators := L.Iterators + 1;
end Lock;
----------
-- Next --
----------
procedure Next
(Iter : in out Iterator;
Elem : out Element_Type)
is
procedure Next (Iter : in out Iterator; Elem : out Element_Type) is
Is_OK : constant Boolean := Is_Valid (Iter);
Saved : constant Node_Ptr := Iter.Nod;
@ -617,6 +603,17 @@ package body GNAT.Lists is
end if;
end Replace;
----------
-- Size --
----------
function Size (L : Instance) return Natural is
begin
Ensure_Created (L);
return L.Elements;
end Size;
------------
-- Unlock --
------------
@ -628,7 +625,7 @@ package body GNAT.Lists is
-- The list may be locked multiple times if multiple iterators are
-- operating over it.
L.Locked := L.Locked - 1;
L.Iterators := L.Iterators - 1;
end Unlock;
end Doubly_Linked_List;

55
gcc/ada/libgnat/g-lists.ads
View file

@ -49,14 +49,10 @@ package GNAT.Lists is
--
-- <various operations>
--
-- Destroy (List)
-- Destroy (List);
--
-- The destruction of the list reclaims all storage occupied by it.
-- The following type denotes the number of elements stored in a list
type Element_Count_Type is range 0 .. 2 ** 31 - 1;
generic
type Element_Type is private;
@ -73,21 +69,14 @@ package GNAT.Lists is
type Instance is private;
Nil : constant Instance;
-- The following exception is raised when the list is empty, and an
-- attempt is made to delete an element from it.
List_Empty : exception;
-- This exception is raised when the list is empty, and an attempt is
-- made to delete an element from it.
List_Locked : exception;
-- This exception is raised when the list is being iterated on, and an
-- attempt is made to mutate its state.
Not_Created : exception;
-- This exception is raised when the list has not been created by
-- routine Create, and an attempt is made to read or mutate its state.
procedure Append (L : Instance; Elem : Element_Type);
-- Insert element Elem at the end of list L. This action will raise
-- List_Locked if the list has outstanding iterators.
-- Iterated if the list has outstanding iterators.
function Contains (L : Instance; Elem : Element_Type) return Boolean;
-- Determine whether list L contains element Elem
@ -100,23 +89,23 @@ package GNAT.Lists is
-- not present. This action will raise
--
-- * List_Empty if the list is empty.
-- * List_Locked if the list has outstanding iterators.
-- * Iterated if the list has outstanding iterators.
procedure Delete_First (L : Instance);
-- Delete an element from the start of list L. This action will raise
--
-- * List_Empty if the list is empty.
-- * List_Locked if the list has outstanding iterators.
-- * Iterated if the list has outstanding iterators.
procedure Delete_Last (L : Instance);
-- Delete an element from the end of list L. This action will raise
--
-- * List_Empty if the list is empty.
-- * List_Locked if the list has outstanding iterators.
-- * Iterated if the list has outstanding iterators.
procedure Destroy (L : in out Instance);
-- Destroy the contents of list L. This routine must be called at the
-- end of a list's lifetime. This action will raise List_Locked if the
-- end of a list's lifetime. This action will raise Iterated if the
-- list has outstanding iterators.
function First (L : Instance) return Element_Type;
@ -129,7 +118,7 @@ package GNAT.Lists is
Elem : Element_Type);
-- Insert new element Elem after element After in list L. The routine
-- has no effect if After is not present. This action will raise
-- List_Locked if the list has outstanding iterators.
-- Iterated if the list has outstanding iterators.
procedure Insert_Before
(L : Instance;
@ -137,7 +126,7 @@ package GNAT.Lists is
Elem : Element_Type);
-- Insert new element Elem before element Before in list L. The routine
-- has no effect if After is not present. This action will raise
-- List_Locked if the list has outstanding iterators.
-- Iterated if the list has outstanding iterators.
function Is_Empty (L : Instance) return Boolean;
-- Determine whether list L is empty
@ -146,12 +135,9 @@ package GNAT.Lists is
-- Obtain an element from the end of list L. This action will raise
-- List_Empty if the list is empty.
function Length (L : Instance) return Element_Count_Type;
-- Obtain the number of elements in list L
procedure Prepend (L : Instance; Elem : Element_Type);
-- Insert element Elem at the start of list L. This action will raise
-- List_Locked if the list has outstanding iterators.
-- Iterated if the list has outstanding iterators.
procedure Replace
(L : Instance;
@ -159,7 +145,10 @@ package GNAT.Lists is
New_Elem : Element_Type);
-- Replace old element Old_Elem with new element New_Elem in list L. The
-- routine has no effect if Old_Elem is not present. This action will
-- raise List_Locked if the list has outstanding iterators.
-- raise Iterated if the list has outstanding iterators.
function Size (L : Instance) return Natural;
-- Obtain the number of elements in list L
-------------------------
-- Iterator operations --
@ -179,10 +168,6 @@ package GNAT.Lists is
type Iterator is private;
Iterator_Exhausted : exception;
-- This exception is raised when an iterator is exhausted and further
-- attempts to advance it are made by calling routine Next.
function Iterate (L : Instance) return Iterator;
-- Obtain an iterator over the elements of list L. This action locks all
-- mutation functionality of the associated list.
@ -192,9 +177,7 @@ package GNAT.Lists is
-- iterator has been exhausted, restore all mutation functionality of
-- the associated list.
procedure Next
(Iter : in out Iterator;
Elem : out Element_Type);
procedure Next (Iter : in out Iterator; Elem : out Element_Type);
-- Return the current element referenced by iterator Iter and advance
-- to the next available element. If the iterator has been exhausted
-- and further attempts are made to advance it, this routine restores
@ -216,10 +199,10 @@ package GNAT.Lists is
-- The following type represents a list
type Linked_List is record
Elements : Element_Count_Type := 0;
Elements : Natural := 0;
-- The number of elements in the list
Locked : Natural := 0;
Iterators : Natural := 0;
-- Number of outstanding iterators
Nodes : aliased Node;

131
gcc/ada/libgnat/g-sets.adb Normal file
View file

@ -0,0 +1,131 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . S E T S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body GNAT.Sets is
--------------------
-- Membership_Set --
--------------------
package body Membership_Set is
--------------
-- Contains --
--------------
function Contains (S : Instance; Elem : Element_Type) return Boolean is
begin
return Hashed_Set.Get (Hashed_Set.Instance (S), Elem);
end Contains;
------------
-- Create --
------------
function Create (Initial_Size : Positive) return Instance is
begin
return Instance (Hashed_Set.Create (Initial_Size));
end Create;
------------
-- Delete --
------------
procedure Delete (S : Instance; Elem : Element_Type) is
begin
Hashed_Set.Delete (Hashed_Set.Instance (S), Elem);
end Delete;
-------------
-- Destroy --
-------------
procedure Destroy (S : in out Instance) is
begin
Hashed_Set.Destroy (Hashed_Set.Instance (S));
end Destroy;
--------------
-- Has_Next --
--------------
function Has_Next (Iter : Iterator) return Boolean is
begin
return Hashed_Set.Has_Next (Hashed_Set.Iterator (Iter));
end Has_Next;
------------
-- Insert --
------------
procedure Insert (S : Instance; Elem : Element_Type) is
begin
Hashed_Set.Put (Hashed_Set.Instance (S), Elem, True);
end Insert;
--------------
-- Is_Empty --
--------------
function Is_Empty (S : Instance) return Boolean is
begin
return Hashed_Set.Is_Empty (Hashed_Set.Instance (S));
end Is_Empty;
-------------
-- Iterate --
-------------
function Iterate (S : Instance) return Iterator is
begin
return Iterator (Hashed_Set.Iterate (Hashed_Set.Instance (S)));
end Iterate;
----------
-- Next --
----------
procedure Next (Iter : in out Iterator; Elem : out Element_Type) is
begin
Hashed_Set.Next (Hashed_Set.Iterator (Iter), Elem);
end Next;
----------
-- Size --
----------
function Size (S : Instance) return Natural is
begin
return Hashed_Set.Size (Hashed_Set.Instance (S));
end Size;
end Membership_Set;
end GNAT.Sets;

161
gcc/ada/libgnat/g-sets.ads Normal file
View file

@ -0,0 +1,161 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . S E T S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Compiler_Unit_Warning;
with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
package GNAT.Sets is
--------------------
-- Membership_Set --
--------------------
-- The following package offers a membership set abstraction with the
-- following characteristics:
--
-- * Creation of multiple instances, of different sizes.
-- * Iterable elements.
--
-- The following use pattern must be employed with this set:
--
-- Set : Instance := Create (<some size>);
--
-- <various operations>
--
-- Destroy (Set);
--
-- The destruction of the set reclaims all storage occupied by it.
generic
type Element_Type is private;
with function "="
(Left : Element_Type;
Right : Element_Type) return Boolean;
with function Hash (Key : Element_Type) return Bucket_Range_Type;
-- Map an arbitrary key into the range of buckets
package Membership_Set is
--------------------
-- Set operations --
--------------------
-- The following type denotes a membership set handle. Each instance
-- must be created using routine Create.
type Instance is private;
Nil : constant Instance;
function Contains (S : Instance; Elem : Element_Type) return Boolean;
-- Determine whether membership set S contains element Elem
function Create (Initial_Size : Positive) return Instance;
-- Create a new membership set with bucket capacity Initial_Size. This
-- routine must be called at the start of the membership set's lifetime.
procedure Delete (S : Instance; Elem : Element_Type);
-- Delete element Elem from membership set S. The routine has no effect
-- if the element is not present in the membership set. This action will
-- raise Iterated if the membership set has outstanding iterators.
procedure Destroy (S : in out Instance);
-- Destroy the contents of membership set S, rendering it unusable. This
-- routine must be called at the end of the membership set's lifetime.
-- This action will raise Iterated if the hash table has outstanding
-- iterators.
procedure Insert (S : Instance; Elem : Element_Type);
-- Insert element Elem in membership set S. The routine has no effect
-- if the element is already present in the membership set. This action
-- will raise Iterated if the membership set has outstanding iterators.
function Is_Empty (S : Instance) return Boolean;
-- Determine whether set S is empty
function Size (S : Instance) return Natural;
-- Obtain the number of elements in membership set S
-------------------------
-- Iterator operations --
-------------------------
-- The following type represents an element iterator. An iterator locks
-- all mutation operations, and unlocks them once it is exhausted. The
-- iterator must be used with the following pattern:
--
-- Iter := Iterate (My_Set);
-- while Has_Next (Iter) loop
-- Next (Iter, Element);
-- end loop;
--
-- It is possible to advance the iterator by using Next only, however
-- this risks raising Iterator_Exhausted.
type Iterator is private;
function Iterate (S : Instance) return Iterator;
-- Obtain an iterator over the elements of membership set S. This action
-- locks all mutation functionality of the associated membership set.
function Has_Next (Iter : Iterator) return Boolean;
-- Determine whether iterator Iter has more keys to examine. If the
-- iterator has been exhausted, restore all mutation functionality of
-- the associated membership set.
procedure Next (Iter : in out Iterator; Elem : out Element_Type);
-- Return the current element referenced by iterator Iter and advance
-- to the next available element. If the iterator has been exhausted
-- and further attempts are made to advance it, this routine restores
-- mutation functionality of the associated membership set, and then
-- raises Iterator_Exhausted.
private
package Hashed_Set is new Dynamic_HTable
(Key_Type => Element_Type,
Value_Type => Boolean,
No_Value => False,
Expansion_Threshold => 1.5,
Expansion_Factor => 2,
Compression_Threshold => 0.3,
Compression_Factor => 2,
"=" => "=",
Hash => Hash);
type Instance is new Hashed_Set.Instance;
Nil : constant Instance := Instance (Hashed_Set.Nil);
type Iterator is new Hashed_Set.Iterator;
end Membership_Set;
end GNAT.Sets;

20
gcc/ada/libgnat/gnat.ads
View file

@ -34,4 +34,24 @@
package GNAT is
pragma Pure;
-- The following type denotes the range of buckets for various hashed
-- data structures in the GNAT unit hierarchy.
type Bucket_Range_Type is mod 2 ** 32;
-- The following exception is raised whenever an attempt is made to mutate
-- the state of a data structure that is being iterated on.
Iterated : exception;
-- The following exception is raised when an iterator is exhausted and
-- further attempts are made to advance it.
Iterator_Exhausted : exception;
-- The following exception is raised whenever an attempt is made to mutate
-- the state of a data structure that has not been created yet.
Not_Created : exception;
end GNAT;

6
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,9 @@
2018-09-26 Hristian Kirtchev <kirtchev@adacore.com>
* gnat.dg/sets1.adb: New testcase.
* gnat.dg/dynhash.adb, gnat.dg/linkedlist.adb: Update testcases
to new API.
2018-09-26 Thomas Quinot <quinot@adacore.com>
* gnat.dg/sso12.adb: New testcase.

55
gcc/testsuite/gnat.dg/dynhash.adb
View file

@ -1,6 +1,7 @@
-- { dg-do run }
with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT;
with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
procedure Dynhash is
@ -14,14 +15,14 @@ procedure Dynhash is
Expansion_Factor => 2,
Compression_Threshold => 0.3,
Compression_Factor => 2,
Equivalent_Keys => "=",
"=" => "=",
Hash => Hash);
use DHT;
function Create_And_Populate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Bucket_Range_Type) return Instance;
Init_Size : Positive) return Instance;
-- 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.
@ -50,19 +51,19 @@ procedure Dynhash is
procedure Check_Size
(Caller : String;
T : Instance;
Exp_Count : Pair_Count_Type);
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 : Bucket_Range_Type);
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 : Pair_Count_Type;
Init_Size : Bucket_Range_Type);
Exp_Count : Natural;
Init_Size : Positive);
-- Verify that
--
-- * Put properly inserts values in the hash table.
@ -78,7 +79,7 @@ procedure Dynhash is
procedure Test_Iterate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Bucket_Range_Type);
Init_Size : Positive);
-- Verify that iterators
--
-- * Properly visit each key exactly once.
@ -88,7 +89,7 @@ procedure Dynhash is
-- 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 : Bucket_Range_Type);
procedure Test_Iterate_Empty (Init_Size : Positive);
-- Verify that an iterator over an empty hash table
--
-- * Does not visit any key
@ -100,7 +101,7 @@ procedure Dynhash is
procedure Test_Iterate_Forced
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Bucket_Range_Type);
Init_Size : Positive);
-- Verify that an iterator that is forcefully advanced by just Next
--
-- * Properly visit each key exactly once.
@ -113,7 +114,7 @@ procedure Dynhash is
procedure Test_Replace
(Low_Val : Integer;
High_Val : Integer;
Init_Size : Bucket_Range_Type);
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.
@ -121,7 +122,7 @@ procedure Dynhash is
procedure Test_Reset
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Bucket_Range_Type);
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.
@ -133,7 +134,7 @@ procedure Dynhash is
function Create_And_Populate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Bucket_Range_Type) return Instance
Init_Size : Positive) return Instance
is
T : Instance;
@ -232,7 +233,7 @@ procedure Dynhash is
Delete (T, 1);
Put_Line ("ERROR: " & Caller & ": Delete: no exception raised");
exception
when Table_Locked =>
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
@ -242,7 +243,7 @@ procedure Dynhash is
Destroy (T);
Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised");
exception
when Table_Locked =>
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception");
@ -252,7 +253,7 @@ procedure Dynhash is
Put (T, 1, 1);
Put_Line ("ERROR: " & Caller & ": Put: no exception raised");
exception
when Table_Locked =>
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Put: unexpected exception");
@ -262,7 +263,7 @@ procedure Dynhash is
Reset (T);
Put_Line ("ERROR: " & Caller & ": Reset: no exception raised");
exception
when Table_Locked =>
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Reset: unexpected exception");
@ -276,9 +277,9 @@ procedure Dynhash is
procedure Check_Size
(Caller : String;
T : Instance;
Exp_Count : Pair_Count_Type)
Exp_Count : Natural)
is
Count : constant Pair_Count_Type := Size (T);
Count : constant Natural := Size (T);
begin
if Count /= Exp_Count then
@ -301,8 +302,8 @@ procedure Dynhash is
-- Test_Create --
-----------------
procedure Test_Create (Init_Size : Bucket_Range_Type) is
Count : Pair_Count_Type;
procedure Test_Create (Init_Size : Positive) is
Count : Natural;
Iter : Iterator;
T : Instance;
Val : Integer;
@ -397,8 +398,8 @@ procedure Dynhash is
procedure Test_Delete_Get_Put_Size
(Low_Key : Integer;
High_Key : Integer;
Exp_Count : Pair_Count_Type;
Init_Size : Bucket_Range_Type)
Exp_Count : Natural;
Init_Size : Positive)
is
Exp_Val : Integer;
T : Instance;
@ -478,7 +479,7 @@ procedure Dynhash is
procedure Test_Iterate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Bucket_Range_Type)
Init_Size : Positive)
is
Iter_1 : Iterator;
Iter_2 : Iterator;
@ -548,7 +549,7 @@ procedure Dynhash is
-- Test_Iterate_Empty --
------------------------
procedure Test_Iterate_Empty (Init_Size : Bucket_Range_Type) is
procedure Test_Iterate_Empty (Init_Size : Positive) is
Iter : Iterator;
Key : Integer;
T : Instance;
@ -594,7 +595,7 @@ procedure Dynhash is
procedure Test_Iterate_Forced
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Bucket_Range_Type)
Init_Size : Positive)
is
Iter : Iterator;
Key : Integer;
@ -649,7 +650,7 @@ procedure Dynhash is
procedure Test_Replace
(Low_Val : Integer;
High_Val : Integer;
Init_Size : Bucket_Range_Type)
Init_Size : Positive)
is
Key : constant Integer := 1;
T : Instance;
@ -684,7 +685,7 @@ procedure Dynhash is
procedure Test_Reset
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Bucket_Range_Type)
Init_Size : Positive)
is
T : Instance;

127
gcc/testsuite/gnat.dg/linkedlist.adb
View file

@ -1,6 +1,7 @@
-- { dg-do run }
with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT;
with GNAT.Lists; use GNAT.Lists;
procedure Linkedlist is
@ -97,15 +98,15 @@ procedure Linkedlist is
procedure Test_Last;
-- Verify that Last properly returns the tail of a list
procedure Test_Length;
-- Verify that Length returns the correct length of a list
procedure Test_Prepend;
-- Verify that Prepend properly inserts at the head of 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 --
-----------------
@ -116,7 +117,7 @@ procedure Linkedlist is
Low_Elem : Integer;
High_Elem : Integer)
is
Len : constant Element_Count_Type := Length (L);
Len : constant Natural := Size (L);
begin
for Elem in Low_Elem .. High_Elem loop
@ -142,7 +143,7 @@ procedure Linkedlist is
Append (L, 1);
Put_Line ("ERROR: " & Caller & ": Append: no exception raised");
exception
when List_Locked =>
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Append: unexpected exception");
@ -154,7 +155,7 @@ procedure Linkedlist is
exception
when List_Empty =>
null;
when List_Locked =>
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
@ -166,7 +167,7 @@ procedure Linkedlist is
exception
when List_Empty =>
null;
when List_Locked =>
when Iterated =>
null;
when others =>
Put_Line
@ -179,7 +180,7 @@ procedure Linkedlist is
exception
when List_Empty =>
null;
when List_Locked =>
when Iterated =>
null;
when others =>
Put_Line
@ -190,7 +191,7 @@ procedure Linkedlist is
Destroy (L);
Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised");
exception
when List_Locked =>
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception");
@ -200,7 +201,7 @@ procedure Linkedlist is
Insert_After (L, 1, 2);
Put_Line ("ERROR: " & Caller & ": Insert_After: no exception raised");
exception
when List_Locked =>
when Iterated =>
null;
when others =>
Put_Line
@ -212,7 +213,7 @@ procedure Linkedlist is
Put_Line
("ERROR: " & Caller & ": Insert_Before: no exception raised");
exception
when List_Locked =>
when Iterated =>
null;
when others =>
Put_Line
@ -223,7 +224,7 @@ procedure Linkedlist is
Prepend (L, 1);
Put_Line ("ERROR: " & Caller & ": Prepend: no exception raised");
exception
when List_Locked =>
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Prepend: unexpected exception");
@ -233,7 +234,7 @@ procedure Linkedlist is
Replace (L, 1, 2);
Put_Line ("ERROR: " & Caller & ": Replace: no exception raised");
exception
when List_Locked =>
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Replace: unexpected exception");
@ -384,7 +385,7 @@ procedure Linkedlist is
-----------------
procedure Test_Create is
Count : Element_Count_Type;
Count : Natural;
Flag : Boolean;
Iter : Iterator;
L : Instance;
@ -507,16 +508,6 @@ procedure Linkedlist is
Put_Line ("ERROR: Test_Create: Last: unexpected exception");
end;
begin
Count := Length (L);
Put_Line ("ERROR: Test_Create: Length: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Length: unexpected exception");
end;
begin
Prepend (L, 1);
Put_Line ("ERROR: Test_Create: Prepend: no exception raised");
@ -536,6 +527,16 @@ procedure Linkedlist is
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;
-----------------
@ -1055,44 +1056,6 @@ procedure Linkedlist is
Destroy (L);
end Test_Last;
-----------------
-- Test_Length --
-----------------
procedure Test_Length is
L : Instance := Create;
Len : Element_Count_Type;
begin
Len := Length (L);
if Len /= 0 then
Put_Line ("ERROR: Test_Length: wrong length");
Put_Line ("expected: 0");
Put_Line ("got :" & Len'Img);
end if;
Populate_With_Append (L, 1, 2);
Len := Length (L);
if Len /= 2 then
Put_Line ("ERROR: Test_Length: wrong length");
Put_Line ("expected: 2");
Put_Line ("got :" & Len'Img);
end if;
Populate_With_Append (L, 3, 6);
Len := Length (L);
if Len /= 6 then
Put_Line ("ERROR: Test_Length: wrong length");
Put_Line ("expected: 6");
Put_Line ("got :" & Len'Img);
end if;
Destroy (L);
end Test_Length;
------------------
-- Test_Prepend --
------------------
@ -1143,6 +1106,44 @@ procedure Linkedlist is
Destroy (L);
end Test_Replace;
---------------
-- Test_Size --
---------------
procedure Test_Size is
L : Instance := 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
@ -1178,7 +1179,7 @@ begin
High_Elem => 5);
Test_Last;
Test_Length;
Test_Prepend;
Test_Replace;
Test_Size;
end Linkedlist;

634
gcc/testsuite/gnat.dg/sets1.adb Normal file
View file

@ -0,0 +1,634 @@
-- { dg-do run }
with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT;
with GNAT.Sets; use GNAT.Sets;
procedure Sets1 is
function Hash (Key : Integer) return Bucket_Range_Type;
package Integer_Sets is new Membership_Set
(Element_Type => Integer,
"=" => "=",
Hash => Hash);
use Integer_Sets;
procedure Check_Empty
(Caller : String;
S : Instance;
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 Instance);
-- Ensure that all mutation operations of set S are locked
procedure Check_Present
(Caller : String;
S : Instance;
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 Instance);
-- Ensure that all mutation operations of set S are unlocked
procedure Populate
(S : Instance;
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 : Instance;
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 Instance) 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 : Instance;
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 Instance) 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 : Instance;
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 : Instance := 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 : Instance;
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 : Instance := 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 : Instance := 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 : Instance := 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 : Instance := 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 : Instance := 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 : Instance := 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 Sets1;