This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] New unit GNAT.Sets
- From: Pierre-Marie de Rodat <derodat at adacore dot com>
- To: gcc-patches at gcc dot gnu dot org
- Cc: Hristian Kirtchev <kirtchev at adacore dot com>
- Date: Wed, 26 Sep 2018 05:24:35 -0400
- Subject: [Ada] New unit GNAT.Sets
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.
Tested on x86_64-pc-linux-gnu, committed on trunk
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.
--- gcc/ada/Makefile.rtl
+++ gcc/ada/Makefile.rtl
@@ -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) \
--- gcc/ada/gcc-interface/Make-lang.in
+++ gcc/ada/gcc-interface/Make-lang.in
@@ -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 \
--- gcc/ada/impunit.adb
+++ gcc/ada/impunit.adb
@@ -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
--- gcc/ada/libgnat/g-dynhta.adb
+++ gcc/ada/libgnat/g-dynhta.adb
@@ -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;
@@ -798,6 +799,17 @@ package body GNAT.Dynamic_HTables is
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;
--- gcc/ada/libgnat/g-dynhta.ads
+++ gcc/ada/libgnat/g-dynhta.ads
@@ -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;
--- gcc/ada/libgnat/g-lists.adb
+++ gcc/ada/libgnat/g-lists.adb
@@ -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;
--- gcc/ada/libgnat/g-lists.ads
+++ gcc/ada/libgnat/g-lists.ads
@@ -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;
- List_Empty : exception;
- -- This exception is raised when the list is empty, and an attempt is
- -- made to delete an element from it.
+ -- The following 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.
+ List_Empty : exception;
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;
--- /dev/null
new file mode 100644
+++ gcc/ada/libgnat/g-sets.adb
@@ -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;
--- /dev/null
new file mode 100644
+++ gcc/ada/libgnat/g-sets.ads
@@ -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;
--- gcc/ada/libgnat/gnat.ads
+++ gcc/ada/libgnat/gnat.ads
@@ -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;
--- gcc/testsuite/gnat.dg/dynhash.adb
+++ gcc/testsuite/gnat.dg/dynhash.adb
@@ -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");
@@ -273,12 +274,12 @@ procedure Dynhash is
-- Check_Size --
----------------
- procedure Check_Size
+ 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;
@@ -527,7 +528,7 @@ procedure Dynhash is
-- operations of the hash table because all outstanding iterators have
-- been exhausted.
- Check_Keys
+ Check_Keys
(Caller => "Test_Iterate",
Iter => Iter_2,
Low_Key => Low_Key,
@@ -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;
@@ -681,10 +682,10 @@ procedure Dynhash is
-- Test_Reset --
----------------
- procedure Test_Reset
+ procedure Test_Reset
(Low_Key : Integer;
High_Key : Integer;
- Init_Size : Bucket_Range_Type)
+ Init_Size : Positive)
is
T : Instance;
--- gcc/testsuite/gnat.dg/linkedlist.adb
+++ gcc/testsuite/gnat.dg/linkedlist.adb
@@ -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,10 +180,10 @@ procedure Linkedlist is
exception
when List_Empty =>
null;
- when List_Locked =>
+ when Iterated =>
null;
when others =>
- Put_Line
+ Put_Line
("ERROR: " & Caller & ": Delete_Last: unexpected exception");
end;
@@ -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,10 +201,10 @@ 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
+ Put_Line
("ERROR: " & Caller & ": Insert_After: unexpected exception");
end;
@@ -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;
@@ -508,33 +509,33 @@ procedure Linkedlist is
end;
begin
- Count := Length (L);
- Put_Line ("ERROR: Test_Create: Length: no exception raised");
+ Prepend (L, 1);
+ Put_Line ("ERROR: Test_Create: Prepend: no exception raised");
exception
when Not_Created =>
null;
when others =>
- Put_Line ("ERROR: Test_Create: Length: unexpected exception");
+ Put_Line ("ERROR: Test_Create: Prepend: unexpected exception");
end;
begin
- Prepend (L, 1);
- Put_Line ("ERROR: Test_Create: Prepend: no exception raised");
+ 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: Prepend: unexpected exception");
+ Put_Line ("ERROR: Test_Create: Replace: unexpected exception");
end;
begin
- Replace (L, 1, 2);
- Put_Line ("ERROR: Test_Create: Replace: no exception raised");
+ Count := Size (L);
+ Put_Line ("ERROR: Test_Create: Size: no exception raised");
exception
when Not_Created =>
null;
when others =>
- Put_Line ("ERROR: Test_Create: Replace: unexpected exception");
+ Put_Line ("ERROR: Test_Create: Size: unexpected exception");
end;
end Test_Create;
@@ -654,7 +655,7 @@ procedure Linkedlist is
-- At this point the list should be completely empty
- Check_Empty
+ Check_Empty
(Caller => "Test_Delete_First",
L => L,
Low_Elem => Low_Elem,
@@ -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;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/sets1.adb
@@ -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;