1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT LIBRARY COMPONENTS                          --
4--                                                                          --
5--                  ADA.CONTAINERS.INDEFINITE_HASHED_SETS                   --
6--                                                                          --
7--                                 S p e c                                  --
8--                                                                          --
9--          Copyright (C) 2004-2021, Free Software Foundation, Inc.         --
10--                                                                          --
11-- This specification is derived from the Ada Reference Manual for use with --
12-- GNAT. The copyright notice above, and the license provisions that follow --
13-- apply solely to the  contents of the part following the private keyword. --
14--                                                                          --
15-- GNAT is free software;  you can  redistribute it  and/or modify it under --
16-- terms of the  GNU General Public License as published  by the Free Soft- --
17-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
18-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
19-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
20-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
21--                                                                          --
22-- As a special exception under Section 7 of GPL version 3, you are granted --
23-- additional permissions described in the GCC Runtime Library Exception,   --
24-- version 3.1, as published by the Free Software Foundation.               --
25--                                                                          --
26-- You should have received a copy of the GNU General Public License and    --
27-- a copy of the GCC Runtime Library Exception along with this program;     --
28-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
29-- <http://www.gnu.org/licenses/>.                                          --
30--                                                                          --
31-- This unit was originally developed by Matthew J Heaney.                  --
32------------------------------------------------------------------------------
33
34with Ada.Iterator_Interfaces;
35
36private with Ada.Containers.Hash_Tables;
37with Ada.Containers.Helpers;
38private with Ada.Streams;
39private with Ada.Finalization;
40private with Ada.Strings.Text_Buffers;
41
42generic
43   type Element_Type (<>) is private;
44
45   with function Hash (Element : Element_Type) return Hash_Type;
46
47   with function Equivalent_Elements (Left, Right : Element_Type)
48                                     return Boolean;
49
50   with function "=" (Left, Right : Element_Type) return Boolean is <>;
51
52package Ada.Containers.Indefinite_Hashed_Sets with
53  SPARK_Mode => Off
54is
55   pragma Annotate (CodePeer, Skip_Analysis);
56   pragma Preelaborate;
57   pragma Remote_Types;
58
59   type Set is tagged private
60     with Constant_Indexing => Constant_Reference,
61          Default_Iterator  => Iterate,
62          Iterator_Element  => Element_Type,
63          Aggregate         => (Empty       => Empty,
64                                Add_Unnamed => Include);
65
66   pragma Preelaborable_Initialization (Set);
67
68   type Cursor is private;
69   pragma Preelaborable_Initialization (Cursor);
70
71   Empty_Set : constant Set;
72   --  Set objects declared without an initialization expression are
73   --  initialized to the value Empty_Set.
74
75   function Empty (Capacity : Count_Type := 1000) return Set;
76
77   No_Element : constant Cursor;
78   --  Cursor objects declared without an initialization expression are
79   --  initialized to the value No_Element.
80
81   function Has_Element (Position : Cursor) return Boolean;
82   --  Equivalent to Position /= No_Element
83
84   package Set_Iterator_Interfaces is new
85     Ada.Iterator_Interfaces (Cursor, Has_Element);
86
87   function "=" (Left, Right : Set) return Boolean;
88   --  For each element in Left, set equality attempts to find the equal
89   --  element in Right; if a search fails, then set equality immediately
90   --  returns False. The search works by calling Hash to find the bucket in
91   --  the Right set that corresponds to the Left element. If the bucket is
92   --  non-empty, the search calls the generic formal element equality operator
93   --  to compare the element (in Left) to the element of each node in the
94   --  bucket (in Right); the search terminates when a matching node in the
95   --  bucket is found, or the nodes in the bucket are exhausted. (Note that
96   --  element equality is called here, not Equivalent_Elements. Set equality
97   --  is the only operation in which element equality is used. Compare set
98   --  equality to Equivalent_Sets, which does call Equivalent_Elements.)
99
100   function Equivalent_Sets (Left, Right : Set) return Boolean;
101   --  Similar to set equality, with the difference that the element in Left is
102   --  compared to the elements in Right using the generic formal
103   --  Equivalent_Elements operation instead of element equality.
104
105   function To_Set (New_Item : Element_Type) return Set;
106   --  Constructs a singleton set comprising New_Element. To_Set calls Hash to
107   --  determine the bucket for New_Item.
108
109   function Capacity (Container : Set) return Count_Type;
110   --  Returns the current capacity of the set. Capacity is the maximum length
111   --  before which rehashing in guaranteed not to occur.
112
113   procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type);
114   --  Adjusts the current capacity, by allocating a new buckets array. If the
115   --  requested capacity is less than the current capacity, then the capacity
116   --  is contracted (to a value not less than the current length). If the
117   --  requested capacity is greater than the current capacity, then the
118   --  capacity is expanded (to a value not less than what is requested). In
119   --  either case, the nodes are rehashed from the old buckets array onto the
120   --  new buckets array (Hash is called once for each existing element in
121   --  order to compute the new index), and then the old buckets array is
122   --  deallocated.
123
124   function Length (Container : Set) return Count_Type;
125   --  Returns the number of items in the set
126
127   function Is_Empty (Container : Set) return Boolean;
128   --  Equivalent to Length (Container) = 0
129
130   procedure Clear (Container : in out Set);
131   --  Removes all of the items from the set
132
133   function Element (Position : Cursor) return Element_Type;
134   --  Returns the element of the node designated by the cursor
135
136   procedure Replace_Element
137     (Container : in out Set;
138      Position  : Cursor;
139      New_Item  : Element_Type);
140   --  If New_Item is equivalent (as determined by calling Equivalent_Elements)
141   --  to the element of the node designated by Position, then New_Element is
142   --  assigned to that element. Otherwise, it calls Hash to determine the
143   --  bucket for New_Item. If the bucket is not empty, then it calls
144   --  Equivalent_Elements for each node in that bucket to determine whether
145   --  New_Item is equivalent to an element in that bucket. If
146   --  Equivalent_Elements returns True then Program_Error is raised (because
147   --  an element may appear only once in the set); otherwise, New_Item is
148   --  assigned to the node designated by Position, and the node is moved to
149   --  its new bucket.
150
151   procedure Query_Element
152     (Position : Cursor;
153      Process  : not null access procedure (Element : Element_Type));
154   --  Calls Process with the element (having only a constant view) of the node
155   --  designated by the cursor.
156
157   type Constant_Reference_Type
158     (Element : not null access constant Element_Type) is private
159        with Implicit_Dereference => Element;
160
161   function Constant_Reference
162     (Container : aliased Set;
163      Position  : Cursor) return Constant_Reference_Type;
164   pragma Inline (Constant_Reference);
165
166   procedure Assign (Target : in out Set; Source : Set);
167
168   function Copy (Source : Set; Capacity : Count_Type := 0) return Set;
169
170   procedure Move (Target : in out Set; Source : in out Set);
171   --  Clears Target (if it's not empty), and then moves (not copies) the
172   --  buckets array and nodes from Source to Target.
173
174   procedure Insert
175     (Container : in out Set;
176      New_Item  : Element_Type;
177      Position  : out Cursor;
178      Inserted  : out Boolean);
179   --  Conditionally inserts New_Item into the set. If New_Item is already in
180   --  the set, then Inserted returns False and Position designates the node
181   --  containing the existing element (which is not modified). If New_Item is
182   --  not already in the set, then Inserted returns True and Position
183   --  designates the newly-inserted node containing New_Item. The search for
184   --  an existing element works as follows. Hash is called to determine
185   --  New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements
186   --  is called to compare New_Item to the element of each node in that
187   --  bucket. If the bucket is empty, or there were no equivalent elements in
188   --  the bucket, the search "fails" and the New_Item is inserted in the set
189   --  (and Inserted returns True); otherwise, the search "succeeds" (and
190   --  Inserted returns False).
191
192   procedure Insert  (Container : in out Set; New_Item : Element_Type);
193   --  Attempts to insert New_Item into the set, performing the usual insertion
194   --  search (which involves calling both Hash and Equivalent_Elements); if
195   --  the search succeeds (New_Item is equivalent to an element already in the
196   --  set, and so was not inserted), then this operation raises
197   --  Constraint_Error. (This version of Insert is similar to Replace, but
198   --  having the opposite exception behavior. It is intended for use when you
199   --  want to assert that the item is not already in the set.)
200
201   procedure Include (Container : in out Set; New_Item : Element_Type);
202   --  Attempts to insert New_Item into the set. If an element equivalent to
203   --  New_Item is already in the set (the insertion search succeeded, and
204   --  hence New_Item was not inserted), then the value of New_Item is assigned
205   --  to the existing element. (This insertion operation only raises an
206   --  exception if cursor tampering occurs. It is intended for use when you
207   --  want to insert the item in the set, and you don't care whether an
208   --  equivalent element is already present.)
209
210   procedure Replace (Container : in out Set; New_Item : Element_Type);
211   --  Searches for New_Item in the set; if the search fails (because an
212   --  equivalent element was not in the set), then it raises
213   --  Constraint_Error. Otherwise, the existing element is assigned the value
214   --  New_Item. (This is similar to Insert, but with the opposite exception
215   --  behavior. It is intended for use when you want to assert that the item
216   --  is already in the set.)
217
218   procedure Exclude (Container : in out Set; Item : Element_Type);
219   --  Searches for Item in the set, and if found, removes its node from the
220   --  set and then deallocates it. The search works as follows. The operation
221   --  calls Hash to determine the item's bucket; if the bucket is not empty,
222   --  it calls Equivalent_Elements to compare Item to the element of each node
223   --  in the bucket. (This is the deletion analog of Include. It is intended
224   --  for use when you want to remove the item from the set, but don't care
225   --  whether the item is already in the set.)
226
227   procedure Delete  (Container : in out Set; Item : Element_Type);
228   --  Searches for Item in the set (which involves calling both Hash and
229   --  Equivalent_Elements). If the search fails, then the operation raises
230   --  Constraint_Error. Otherwise it removes the node from the set and then
231   --  deallocates it. (This is the deletion analog of non-conditional
232   --  Insert. It is intended for use when you want to assert that the item is
233   --  already in the set.)
234
235   procedure Delete (Container : in out Set; Position  : in out Cursor);
236   --  Removes the node designated by Position from the set, and then
237   --  deallocates the node. The operation calls Hash to determine the bucket,
238   --  and then compares Position to each node in the bucket until there's a
239   --  match (it does not call Equivalent_Elements).
240
241   procedure Union (Target : in out Set; Source : Set);
242   --  The operation first calls Reserve_Capacity if the current capacity is
243   --  less than the sum of the lengths of Source and Target. It then iterates
244   --  over the Source set, and conditionally inserts each element into Target.
245
246   function Union (Left, Right : Set) return Set;
247   --  The operation first copies the Left set to the result, and then iterates
248   --  over the Right set to conditionally insert each element into the result.
249
250   function "or" (Left, Right : Set) return Set renames Union;
251
252   procedure Intersection (Target : in out Set; Source : Set);
253   --  Iterates over the Target set (calling First and Next), calling Find to
254   --  determine whether the element is in Source. If an equivalent element is
255   --  not found in Source, the element is deleted from Target.
256
257   function Intersection (Left, Right : Set) return Set;
258   --  Iterates over the Left set, calling Find to determine whether the
259   --  element is in Right. If an equivalent element is found, it is inserted
260   --  into the result set.
261
262   function "and" (Left, Right : Set) return Set renames Intersection;
263
264   procedure Difference (Target : in out Set; Source : Set);
265   --  Iterates over the Source (calling First and Next), calling Find to
266   --  determine whether the element is in Target. If an equivalent element is
267   --  found, it is deleted from Target.
268
269   function Difference (Left, Right : Set) return Set;
270   --  Iterates over the Left set, calling Find to determine whether the
271   --  element is in the Right set. If an equivalent element is not found, the
272   --  element is inserted into the result set.
273
274   function "-" (Left, Right : Set) return Set renames Difference;
275
276   procedure Symmetric_Difference (Target : in out Set; Source : Set);
277   --  The operation first calls Reserve_Capacity if the current capacity is
278   --  less than the sum of the lengths of Source and Target. It then iterates
279   --  over the Source set, searching for the element in Target (calling Hash
280   --  and Equivalent_Elements). If an equivalent element is found, it is
281   --  removed from Target; otherwise it is inserted into Target.
282
283   function Symmetric_Difference (Left, Right : Set) return Set;
284   --  The operation first iterates over the Left set. It calls Find to
285   --  determine whether the element is in the Right set. If no equivalent
286   --  element is found, the element from Left is inserted into the result. The
287   --  operation then iterates over the Right set, to determine whether the
288   --  element is in the Left set. If no equivalent element is found, the Right
289   --  element is inserted into the result.
290
291   function "xor" (Left, Right : Set) return Set
292     renames Symmetric_Difference;
293
294   function Overlap (Left, Right : Set) return Boolean;
295   --  Iterates over the Left set (calling First and Next), calling Find to
296   --  determine whether the element is in the Right set. If an equivalent
297   --  element is found, the operation immediately returns True. The operation
298   --  returns False if the iteration over Left terminates without finding any
299   --  equivalent element in Right.
300
301   function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
302   --  Iterates over Subset (calling First and Next), calling Find to determine
303   --  whether the element is in Of_Set. If no equivalent element is found in
304   --  Of_Set, the operation immediately returns False. The operation returns
305   --  True if the iteration over Subset terminates without finding an element
306   --  not in Of_Set (that is, every element in Subset is equivalent to an
307   --  element in Of_Set).
308
309   function First (Container : Set) return Cursor;
310   --  Returns a cursor that designates the first non-empty bucket, by
311   --  searching from the beginning of the buckets array.
312
313   function Next (Position : Cursor) return Cursor;
314   --  Returns a cursor that designates the node that follows the current one
315   --  designated by Position. If Position designates the last node in its
316   --  bucket, the operation calls Hash to compute the index of this bucket,
317   --  and searches the buckets array for the first non-empty bucket, starting
318   --  from that index; otherwise, it simply follows the link to the next node
319   --  in the same bucket.
320
321   procedure Next (Position : in out Cursor);
322   --  Equivalent to Position := Next (Position)
323
324   function Find (Container : Set; Item : Element_Type) return Cursor;
325   --  Searches for Item in the set. Find calls Hash to determine the item's
326   --  bucket; if the bucket is not empty, it calls Equivalent_Elements to
327   --  compare Item to each element in the bucket. If the search succeeds, Find
328   --  returns a cursor designating the node containing the equivalent element;
329   --  otherwise, it returns No_Element.
330
331   function Contains (Container : Set; Item : Element_Type) return Boolean;
332   --  Equivalent to Find (Container, Item) /= No_Element
333
334   function Equivalent_Elements (Left, Right : Cursor) return Boolean;
335   --  Returns the result of calling Equivalent_Elements with the elements of
336   --  the nodes designated by cursors Left and Right.
337
338   function Equivalent_Elements
339     (Left  : Cursor;
340      Right : Element_Type) return Boolean;
341   --  Returns the result of calling Equivalent_Elements with element of the
342   --  node designated by Left and element Right.
343
344   function Equivalent_Elements
345     (Left  : Element_Type;
346      Right : Cursor) return Boolean;
347   --  Returns the result of calling Equivalent_Elements with element Left and
348   --  the element of the node designated by Right.
349
350   procedure Iterate
351     (Container : Set;
352      Process   : not null access procedure (Position : Cursor));
353   --  Calls Process for each node in the set
354
355   function Iterate (Container : Set)
356     return Set_Iterator_Interfaces.Forward_Iterator'Class;
357
358   generic
359      type Key_Type (<>) is private;
360
361      with function Key (Element : Element_Type) return Key_Type;
362
363      with function Hash (Key : Key_Type) return Hash_Type;
364
365      with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
366
367   package Generic_Keys is
368
369      function Key (Position : Cursor) return Key_Type;
370      --  Applies generic formal operation Key to the element of the node
371      --  designated by Position.
372
373      function Element (Container : Set; Key : Key_Type) return Element_Type;
374      --  Searches (as per the key-based Find) for the node containing Key, and
375      --  returns the associated element.
376
377      procedure Replace
378        (Container : in out Set;
379         Key       : Key_Type;
380         New_Item  : Element_Type);
381      --  Searches (as per the key-based Find) for the node containing Key, and
382      --  then replaces the element of that node (as per the element-based
383      --  Replace_Element).
384
385      procedure Exclude (Container : in out Set; Key : Key_Type);
386      --  Searches for Key in the set, and if found, removes its node from the
387      --  set and then deallocates it. The search works by first calling Hash
388      --  (on Key) to determine the bucket; if the bucket is not empty, it
389      --  calls Equivalent_Keys to compare parameter Key to the value of
390      --  generic formal operation Key applied to element of each node in the
391      --  bucket.
392
393      procedure Delete (Container : in out Set; Key : Key_Type);
394      --  Deletes the node containing Key as per Exclude, with the difference
395      --  that Constraint_Error is raised if Key is not found.
396
397      function Find (Container : Set; Key : Key_Type) return Cursor;
398      --  Searches for the node containing Key, and returns a cursor
399      --  designating the node. The search works by first calling Hash (on Key)
400      --  to determine the bucket. If the bucket is not empty, the search
401      --  compares Key to the element of each node in the bucket, and returns
402      --  the matching node. The comparison itself works by applying the
403      --  generic formal Key operation to the element of the node, and then
404      --  calling generic formal operation Equivalent_Keys.
405
406      function Contains (Container : Set; Key : Key_Type) return Boolean;
407      --  Equivalent to Find (Container, Key) /= No_Element
408
409      procedure Update_Element_Preserving_Key
410        (Container : in out Set;
411         Position  : Cursor;
412         Process   : not null access
413                       procedure (Element : in out Element_Type));
414      --  Calls Process with the element of the node designated by Position,
415      --  but with the restriction that the key-value of the element is not
416      --  modified. The operation first makes a copy of the value returned by
417      --  applying generic formal operation Key on the element of the node, and
418      --  then calls Process with the element. The operation verifies that the
419      --  key-part has not been modified by calling generic formal operation
420      --  Equivalent_Keys to compare the saved key-value to the value returned
421      --  by applying generic formal operation Key to the post-Process value of
422      --  element. If the key values compare equal then the operation
423      --  completes. Otherwise, the node is removed from the map and
424      --  Program_Error is raised.
425
426      type Reference_Type (Element : not null access Element_Type) is private
427        with Implicit_Dereference => Element;
428
429      function Reference_Preserving_Key
430        (Container : aliased in out Set;
431         Position  : Cursor) return Reference_Type;
432
433      function Constant_Reference
434        (Container : aliased Set;
435         Key       : Key_Type) return Constant_Reference_Type;
436
437      function Reference_Preserving_Key
438        (Container : aliased in out Set;
439         Key       : Key_Type) return Reference_Type;
440
441   private
442      type Set_Access is access all Set;
443      for Set_Access'Storage_Size use 0;
444
445      package Impl is new Helpers.Generic_Implementation;
446
447      type Reference_Control_Type is
448        new Impl.Reference_Control_Type with
449      record
450         Container : Set_Access;
451         Index     : Hash_Type;
452         Old_Pos   : Cursor;
453         Old_Hash  : Hash_Type;
454      end record;
455
456      overriding procedure Finalize (Control : in out Reference_Control_Type);
457      pragma Inline (Finalize);
458
459      type Reference_Type (Element : not null access Element_Type) is record
460         Control : Reference_Control_Type :=
461           raise Program_Error with "uninitialized reference";
462         --  The RM says, "The default initialization of an object of
463         --  type Constant_Reference_Type or Reference_Type propagates
464         --  Program_Error."
465      end record;
466
467      use Ada.Streams;
468
469      procedure Read
470        (Stream : not null access Root_Stream_Type'Class;
471         Item   : out Reference_Type);
472
473      for Reference_Type'Read use Read;
474
475      procedure Write
476        (Stream : not null access Root_Stream_Type'Class;
477         Item   : Reference_Type);
478
479      for Reference_Type'Write use Write;
480   end Generic_Keys;
481
482private
483   pragma Inline (Next);
484
485   type Node_Type;
486   type Node_Access is access Node_Type;
487
488   type Element_Access is access all Element_Type;
489
490   type Node_Type is limited record
491      Element : Element_Access;
492      Next    : Node_Access;
493   end record;
494
495   package HT_Types is
496     new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access);
497
498   type Set is new Ada.Finalization.Controlled with record
499      HT : HT_Types.Hash_Table_Type;
500   end record with Put_Image => Put_Image;
501
502   procedure Put_Image
503     (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
504
505   overriding procedure Adjust (Container : in out Set);
506
507   overriding procedure Finalize (Container : in out Set);
508
509   use HT_Types, HT_Types.Implementation;
510   use Ada.Finalization;
511   use Ada.Streams;
512
513   procedure Write
514     (Stream    : not null access Root_Stream_Type'Class;
515      Container : Set);
516
517   for Set'Write use Write;
518
519   procedure Read
520     (Stream    : not null access Root_Stream_Type'Class;
521      Container : out Set);
522
523   for Set'Read use Read;
524
525   type Set_Access is access all Set;
526   for Set_Access'Storage_Size use 0;
527
528   type Cursor is record
529      Container : Set_Access;
530      Node      : Node_Access;
531   end record;
532
533   procedure Write
534     (Stream : not null access Root_Stream_Type'Class;
535      Item   : Cursor);
536
537   for Cursor'Write use Write;
538
539   procedure Read
540     (Stream : not null access Root_Stream_Type'Class;
541      Item   : out Cursor);
542
543   for Cursor'Read use Read;
544
545   subtype Reference_Control_Type is Implementation.Reference_Control_Type;
546   --  It is necessary to rename this here, so that the compiler can find it
547
548   type Constant_Reference_Type
549     (Element : not null access constant Element_Type) is
550      record
551         Control : Reference_Control_Type :=
552           raise Program_Error with "uninitialized reference";
553         --  The RM says, "The default initialization of an object of
554         --  type Constant_Reference_Type or Reference_Type propagates
555         --  Program_Error."
556      end record;
557
558   procedure Read
559     (Stream : not null access Root_Stream_Type'Class;
560      Item   : out Constant_Reference_Type);
561
562   for Constant_Reference_Type'Read use Read;
563
564   procedure Write
565     (Stream : not null access Root_Stream_Type'Class;
566      Item   : Constant_Reference_Type);
567
568   for Constant_Reference_Type'Write use Write;
569
570   --  Three operations are used to optimize in the expansion of "for ... of"
571   --  loops: the Next(Cursor) procedure in the visible part, and the following
572   --  Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for
573   --  details.
574
575   function Pseudo_Reference
576     (Container : aliased Set'Class) return Reference_Control_Type;
577   pragma Inline (Pseudo_Reference);
578   --  Creates an object of type Reference_Control_Type pointing to the
579   --  container, and increments the Lock. Finalization of this object will
580   --  decrement the Lock.
581
582   function Get_Element_Access
583     (Position : Cursor) return not null Element_Access;
584   --  Returns a pointer to the element designated by Position.
585
586   Empty_Set : constant Set := (Controlled with others => <>);
587
588   No_Element : constant Cursor := (Container => null, Node => null);
589
590   type Iterator is new Limited_Controlled and
591     Set_Iterator_Interfaces.Forward_Iterator with
592   record
593      Container : Set_Access;
594   end record
595     with Disable_Controlled => not T_Check;
596
597   overriding procedure Finalize (Object : in out Iterator);
598
599   overriding function First (Object : Iterator) return Cursor;
600
601   overriding function Next
602     (Object   : Iterator;
603      Position : Cursor) return Cursor;
604
605end Ada.Containers.Indefinite_Hashed_Sets;
606