From f8bc3bcb5fee9140c876d89ae2bf298914c01077 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Wed, 26 Sep 2018 09:18:02 +0000 Subject: [PATCH] [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. 2018-09-26 Hristian Kirtchev 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 --- gcc/ada/ChangeLog | 48 ++ gcc/ada/Makefile.rtl | 1 + gcc/ada/gcc-interface/Make-lang.in | 1 + gcc/ada/impunit.adb | 1 + gcc/ada/libgnat/g-dynhta.adb | 42 +- gcc/ada/libgnat/g-dynhta.ads | 55 +-- gcc/ada/libgnat/g-lists.adb | 37 +- gcc/ada/libgnat/g-lists.ads | 55 +-- gcc/ada/libgnat/g-sets.adb | 131 ++++++ gcc/ada/libgnat/g-sets.ads | 161 +++++++ gcc/ada/libgnat/gnat.ads | 20 + gcc/testsuite/ChangeLog | 6 + gcc/testsuite/gnat.dg/dynhash.adb | 61 +-- gcc/testsuite/gnat.dg/linkedlist.adb | 131 +++--- gcc/testsuite/gnat.dg/sets1.adb | 634 +++++++++++++++++++++++++++ 15 files changed, 1176 insertions(+), 208 deletions(-) create mode 100644 gcc/ada/libgnat/g-sets.adb create mode 100644 gcc/ada/libgnat/g-sets.ads create mode 100644 gcc/testsuite/gnat.dg/sets1.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2f015afe55d..92009ff9d6b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,51 @@ +2018-09-26 Hristian Kirtchev + + * 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 * checks.adb (Install_Null_Excluding_Check): Do not add diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 936a16d32bb..e1b26de67a6 100644 --- a/gcc/ada/Makefile.rtl +++ b/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) \ diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index d8dac73fb38..4866c2ad6a0 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/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 \ diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 3e5fbe07e7c..8f68b553b80 100644 --- a/gcc/ada/impunit.adb +++ b/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 diff --git a/gcc/ada/libgnat/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb index b093e792891..004c276070b 100644 --- a/gcc/ada/libgnat/g-dynhta.adb +++ b/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; @@ -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; diff --git a/gcc/ada/libgnat/g-dynhta.ads b/gcc/ada/libgnat/g-dynhta.ads index 41574fd32d0..b8fb6a61dc5 100644 --- a/gcc/ada/libgnat/g-dynhta.ads +++ b/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; diff --git a/gcc/ada/libgnat/g-lists.adb b/gcc/ada/libgnat/g-lists.adb index a058f33aa7f..ca39a4c3844 100644 --- a/gcc/ada/libgnat/g-lists.adb +++ b/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; diff --git a/gcc/ada/libgnat/g-lists.ads b/gcc/ada/libgnat/g-lists.ads index 777b4f637ae..bf7795a1ee4 100644 --- a/gcc/ada/libgnat/g-lists.ads +++ b/gcc/ada/libgnat/g-lists.ads @@ -49,14 +49,10 @@ package GNAT.Lists is -- -- -- - -- 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; diff --git a/gcc/ada/libgnat/g-sets.adb b/gcc/ada/libgnat/g-sets.adb new file mode 100644 index 00000000000..90a5810c0e7 --- /dev/null +++ b/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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/g-sets.ads b/gcc/ada/libgnat/g-sets.ads new file mode 100644 index 00000000000..59e413b51a0 --- /dev/null +++ b/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 -- +-- . -- +-- -- +-- 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 (); + -- + -- + -- + -- 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; diff --git a/gcc/ada/libgnat/gnat.ads b/gcc/ada/libgnat/gnat.ads index fb160a5d41f..faec6c5ba05 100644 --- a/gcc/ada/libgnat/gnat.ads +++ b/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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5e7a15dde28..459563f3eb9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2018-09-26 Hristian Kirtchev + + * gnat.dg/sets1.adb: New testcase. + * gnat.dg/dynhash.adb, gnat.dg/linkedlist.adb: Update testcases + to new API. + 2018-09-26 Thomas Quinot * gnat.dg/sso12.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/dynhash.adb b/gcc/testsuite/gnat.dg/dynhash.adb index 79e1b984066..c51e6e218e1 100644 --- a/gcc/testsuite/gnat.dg/dynhash.adb +++ b/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; diff --git a/gcc/testsuite/gnat.dg/linkedlist.adb b/gcc/testsuite/gnat.dg/linkedlist.adb index 53a272fe925..b608fe183f1 100644 --- a/gcc/testsuite/gnat.dg/linkedlist.adb +++ b/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; diff --git a/gcc/testsuite/gnat.dg/sets1.adb b/gcc/testsuite/gnat.dg/sets1.adb new file mode 100644 index 00000000000..54a4983a1fa --- /dev/null +++ b/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; -- 2.30.2