1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . H A S H E D _ S E T S --
9 -- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
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. --
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 2, 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. See the GNU General Public License --
21 -- for more details. You should have received a copy of the GNU General --
22 -- Public License distributed with GNAT; see file COPYING. If not, write --
23 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
24 -- Boston, MA 02110-1301, USA. --
26 -- As a special exception, if other files instantiate generics from this --
27 -- unit, or you link this unit with other files to produce an executable, --
28 -- this unit does not by itself cause the resulting executable to be --
29 -- covered by the GNU General Public License. This exception does not --
30 -- however invalidate any other reasons why the executable file might be --
31 -- covered by the GNU Public License. --
33 -- This unit has originally being developed by Matthew J Heaney. --
34 ------------------------------------------------------------------------------
36 with Ada.Unchecked_Deallocation;
38 with Ada.Containers.Hash_Tables.Generic_Operations;
39 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
41 with Ada.Containers.Hash_Tables.Generic_Keys;
42 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
44 with Ada.Containers.Prime_Numbers;
46 with System; use type System.Address;
48 package body Ada.Containers.Hashed_Sets is
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
54 function Copy_Node (Source : Node_Access) return Node_Access;
55 pragma Inline (Copy_Node);
57 function Equivalent_Keys
59 Node : Node_Access) return Boolean;
60 pragma Inline (Equivalent_Keys);
62 function Find_Equal_Key
63 (R_HT : Hash_Table_Type;
64 L_Node : Node_Access) return Boolean;
66 function Find_Equivalent_Key
67 (R_HT : Hash_Table_Type;
68 L_Node : Node_Access) return Boolean;
70 procedure Free (X : in out Node_Access);
72 function Hash_Node (Node : Node_Access) return Hash_Type;
73 pragma Inline (Hash_Node);
76 (HT : in out Hash_Table_Type;
77 New_Item : Element_Type;
78 Node : out Node_Access;
79 Inserted : out Boolean);
82 (HT : Hash_Table_Type;
83 Key : Node_Access) return Boolean;
84 pragma Inline (Is_In);
86 function Next (Node : Node_Access) return Node_Access;
89 function Read_Node (Stream : access Root_Stream_Type'Class)
91 pragma Inline (Read_Node);
93 procedure Replace_Element
94 (HT : in out Hash_Table_Type;
96 New_Item : Element_Type);
98 procedure Set_Next (Node : Node_Access; Next : Node_Access);
99 pragma Inline (Set_Next);
101 function Vet (Position : Cursor) return Boolean;
104 (Stream : access Root_Stream_Type'Class;
106 pragma Inline (Write_Node);
108 --------------------------
109 -- Local Instantiations --
110 --------------------------
113 new Hash_Tables.Generic_Operations
114 (HT_Types => HT_Types,
115 Hash_Node => Hash_Node,
117 Set_Next => Set_Next,
118 Copy_Node => Copy_Node,
121 package Element_Keys is
122 new Hash_Tables.Generic_Keys
123 (HT_Types => HT_Types,
125 Set_Next => Set_Next,
126 Key_Type => Element_Type,
128 Equivalent_Keys => Equivalent_Keys);
131 new HT_Ops.Generic_Equal (Find_Equal_Key);
133 function Is_Equivalent is
134 new HT_Ops.Generic_Equal (Find_Equivalent_Key);
136 procedure Read_Nodes is
137 new HT_Ops.Generic_Read (Read_Node);
139 procedure Write_Nodes is
140 new HT_Ops.Generic_Write (Write_Node);
146 function "=" (Left, Right : Set) return Boolean is
148 return Is_Equal (Left.HT, Right.HT);
155 procedure Adjust (Container : in out Set) is
157 HT_Ops.Adjust (Container.HT);
164 function Capacity (Container : Set) return Count_Type is
166 return HT_Ops.Capacity (Container.HT);
173 procedure Clear (Container : in out Set) is
175 HT_Ops.Clear (Container.HT);
182 function Contains (Container : Set; Item : Element_Type) return Boolean is
184 return Find (Container, Item) /= No_Element;
191 function Copy_Node (Source : Node_Access) return Node_Access is
193 return new Node_Type'(Element => Source.Element, Next => null);
201 (Container : in out Set;
207 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
210 raise Constraint_Error with "attempt to delete element not in set";
217 (Container : in out Set;
218 Position : in out Cursor)
221 if Position.Node = null then
222 raise Constraint_Error with "Position cursor equals No_Element";
225 if Position.Container /= Container'Unrestricted_Access then
226 raise Program_Error with "Position cursor designates wrong set";
229 if Container.HT.Busy > 0 then
230 raise Program_Error with
231 "attempt to tamper with elements (set is busy)";
234 pragma Assert (Vet (Position), "bad cursor in Delete");
236 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
238 Free (Position.Node);
239 Position.Container := null;
247 (Target : in out Set;
250 Tgt_Node : Node_Access;
253 if Target'Address = Source'Address then
258 if Source.HT.Length = 0 then
262 if Target.HT.Busy > 0 then
263 raise Program_Error with
264 "attempt to tamper with elements (set is busy)";
267 -- TODO: This can be written in terms of a loop instead as
268 -- active-iterator style, sort of like a passive iterator.
270 Tgt_Node := HT_Ops.First (Target.HT);
271 while Tgt_Node /= null loop
272 if Is_In (Source.HT, Tgt_Node) then
274 X : Node_Access := Tgt_Node;
276 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
277 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
282 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
287 function Difference (Left, Right : Set) return Set is
288 Buckets : HT_Types.Buckets_Access;
292 if Left'Address = Right'Address then
296 if Left.HT.Length = 0 then
300 if Right.HT.Length = 0 then
305 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
307 Buckets := new Buckets_Type (0 .. Size - 1);
312 Iterate_Left : declare
313 procedure Process (L_Node : Node_Access);
316 new HT_Ops.Generic_Iteration (Process);
322 procedure Process (L_Node : Node_Access) is
324 if not Is_In (Right.HT, L_Node) then
326 J : constant Hash_Type :=
327 Hash (L_Node.Element) mod Buckets'Length;
329 Bucket : Node_Access renames Buckets (J);
332 Bucket := new Node_Type'(L_Node.Element, Bucket);
335 Length := Length + 1;
339 -- Start of processing for Iterate_Left
345 HT_Ops.Free_Hash_Table (Buckets);
349 return (Controlled with HT => (Buckets, Length, 0, 0));
356 function Element (Position : Cursor) return Element_Type is
358 if Position.Node = null then
359 raise Constraint_Error with "Position cursor equals No_Element";
362 pragma Assert (Vet (Position), "bad cursor in function Element");
364 return Position.Node.Element;
367 ---------------------
368 -- Equivalent_Sets --
369 ---------------------
371 function Equivalent_Sets (Left, Right : Set) return Boolean is
373 return Is_Equivalent (Left.HT, Right.HT);
376 -------------------------
377 -- Equivalent_Elements --
378 -------------------------
380 function Equivalent_Elements (Left, Right : Cursor)
383 if Left.Node = null then
384 raise Constraint_Error with
385 "Left cursor of Equivalent_Elements equals No_Element";
388 if Right.Node = null then
389 raise Constraint_Error with
390 "Right cursor of Equivalent_Elements equals No_Element";
393 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
394 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
396 return Equivalent_Elements (Left.Node.Element, Right.Node.Element);
397 end Equivalent_Elements;
399 function Equivalent_Elements (Left : Cursor; Right : Element_Type)
402 if Left.Node = null then
403 raise Constraint_Error with
404 "Left cursor of Equivalent_Elements equals No_Element";
407 pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad");
409 return Equivalent_Elements (Left.Node.Element, Right);
410 end Equivalent_Elements;
412 function Equivalent_Elements (Left : Element_Type; Right : Cursor)
415 if Right.Node = null then
416 raise Constraint_Error with
417 "Right cursor of Equivalent_Elements equals No_Element";
422 "Right cursor of Equivalent_Elements is bad");
424 return Equivalent_Elements (Left, Right.Node.Element);
425 end Equivalent_Elements;
427 ---------------------
428 -- Equivalent_Keys --
429 ---------------------
431 function Equivalent_Keys (Key : Element_Type; Node : Node_Access)
434 return Equivalent_Elements (Key, Node.Element);
442 (Container : in out Set;
447 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
455 procedure Finalize (Container : in out Set) is
457 HT_Ops.Finalize (Container.HT);
466 Item : Element_Type) return Cursor
468 Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
475 return Cursor'(Container'Unrestricted_Access, Node);
482 function Find_Equal_Key
483 (R_HT : Hash_Table_Type;
484 L_Node : Node_Access) return Boolean
486 R_Index : constant Hash_Type :=
487 Element_Keys.Index (R_HT, L_Node.Element);
489 R_Node : Node_Access := R_HT.Buckets (R_Index);
493 if R_Node = null then
497 if L_Node.Element = R_Node.Element then
501 R_Node := Next (R_Node);
505 -------------------------
506 -- Find_Equivalent_Key --
507 -------------------------
509 function Find_Equivalent_Key
510 (R_HT : Hash_Table_Type;
511 L_Node : Node_Access) return Boolean
513 R_Index : constant Hash_Type :=
514 Element_Keys.Index (R_HT, L_Node.Element);
516 R_Node : Node_Access := R_HT.Buckets (R_Index);
520 if R_Node = null then
524 if Equivalent_Elements (L_Node.Element, R_Node.Element) then
528 R_Node := Next (R_Node);
530 end Find_Equivalent_Key;
536 function First (Container : Set) return Cursor is
537 Node : constant Node_Access := HT_Ops.First (Container.HT);
544 return Cursor'(Container'Unrestricted_Access, Node);
551 procedure Free (X : in out Node_Access) is
552 procedure Deallocate is
553 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
557 X.Next := X; -- detect mischief (in Vet)
566 function Has_Element (Position : Cursor) return Boolean is
568 pragma Assert (Vet (Position), "bad cursor in Has_Element");
569 return Position.Node /= null;
576 function Hash_Node (Node : Node_Access) return Hash_Type is
578 return Hash (Node.Element);
586 (Container : in out Set;
587 New_Item : Element_Type)
593 Insert (Container, New_Item, Position, Inserted);
596 if Container.HT.Lock > 0 then
597 raise Program_Error with
598 "attempt to tamper with cursors (set is locked)";
601 Position.Node.Element := New_Item;
610 (Container : in out Set;
611 New_Item : Element_Type;
612 Position : out Cursor;
613 Inserted : out Boolean)
616 Insert (Container.HT, New_Item, Position.Node, Inserted);
617 Position.Container := Container'Unchecked_Access;
621 (Container : in out Set;
622 New_Item : Element_Type)
628 Insert (Container, New_Item, Position, Inserted);
631 raise Constraint_Error with
632 "attempt to insert element already in set";
637 (HT : in out Hash_Table_Type;
638 New_Item : Element_Type;
639 Node : out Node_Access;
640 Inserted : out Boolean)
642 function New_Node (Next : Node_Access) return Node_Access;
643 pragma Inline (New_Node);
645 procedure Local_Insert is
646 new Element_Keys.Generic_Conditional_Insert (New_Node);
652 function New_Node (Next : Node_Access) return Node_Access is
654 return new Node_Type'(New_Item, Next);
657 -- Start of processing for Insert
660 if HT_Ops.Capacity (HT) = 0 then
661 HT_Ops.Reserve_Capacity (HT, 1);
664 Local_Insert (HT, New_Item, Node, Inserted);
667 and then HT.Length > HT_Ops.Capacity (HT)
669 HT_Ops.Reserve_Capacity (HT, HT.Length);
677 procedure Intersection
678 (Target : in out Set;
681 Tgt_Node : Node_Access;
684 if Target'Address = Source'Address then
688 if Source.Length = 0 then
693 if Target.HT.Busy > 0 then
694 raise Program_Error with
695 "attempt to tamper with elements (set is busy)";
698 -- TODO: optimize this to use an explicit
699 -- loop instead of an active iterator
700 -- (similar to how a passive iterator is
703 -- Another possibility is to test which
704 -- set is smaller, and iterate over the
707 Tgt_Node := HT_Ops.First (Target.HT);
708 while Tgt_Node /= null loop
709 if Is_In (Source.HT, Tgt_Node) then
710 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
714 X : Node_Access := Tgt_Node;
716 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
717 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
724 function Intersection (Left, Right : Set) return Set is
725 Buckets : HT_Types.Buckets_Access;
729 if Left'Address = Right'Address then
733 Length := Count_Type'Min (Left.Length, Right.Length);
740 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
742 Buckets := new Buckets_Type (0 .. Size - 1);
747 Iterate_Left : declare
748 procedure Process (L_Node : Node_Access);
751 new HT_Ops.Generic_Iteration (Process);
757 procedure Process (L_Node : Node_Access) is
759 if Is_In (Right.HT, L_Node) then
761 J : constant Hash_Type :=
762 Hash (L_Node.Element) mod Buckets'Length;
764 Bucket : Node_Access renames Buckets (J);
767 Bucket := new Node_Type'(L_Node.Element, Bucket);
770 Length := Length + 1;
774 -- Start of processing for Iterate_Left
780 HT_Ops.Free_Hash_Table (Buckets);
784 return (Controlled with HT => (Buckets, Length, 0, 0));
791 function Is_Empty (Container : Set) return Boolean is
793 return Container.HT.Length = 0;
800 function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
802 return Element_Keys.Find (HT, Key.Element) /= null;
809 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
810 Subset_Node : Node_Access;
813 if Subset'Address = Of_Set'Address then
817 if Subset.Length > Of_Set.Length then
821 -- TODO: rewrite this to loop in the
822 -- style of a passive iterator.
824 Subset_Node := HT_Ops.First (Subset.HT);
825 while Subset_Node /= null loop
826 if not Is_In (Of_Set.HT, Subset_Node) then
829 Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
841 Process : not null access procedure (Position : Cursor))
843 procedure Process_Node (Node : Node_Access);
844 pragma Inline (Process_Node);
847 new HT_Ops.Generic_Iteration (Process_Node);
853 procedure Process_Node (Node : Node_Access) is
855 Process (Cursor'(Container'Unrestricted_Access, Node));
858 -- Start of processing for Iterate
861 -- TODO: resolve whether HT_Ops.Generic_Iteration should
862 -- manipulate busy bit.
864 Iterate (Container.HT);
871 function Length (Container : Set) return Count_Type is
873 return Container.HT.Length;
880 procedure Move (Target : in out Set; Source : in out Set) is
882 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
889 function Next (Node : Node_Access) return Node_Access is
894 function Next (Position : Cursor) return Cursor is
896 if Position.Node = null then
900 pragma Assert (Vet (Position), "bad cursor in Next");
903 HT : Hash_Table_Type renames Position.Container.HT;
904 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
911 return Cursor'(Position.Container, Node);
915 procedure Next (Position : in out Cursor) is
917 Position := Next (Position);
924 function Overlap (Left, Right : Set) return Boolean is
925 Left_Node : Node_Access;
928 if Right.Length = 0 then
932 if Left'Address = Right'Address then
936 Left_Node := HT_Ops.First (Left.HT);
937 while Left_Node /= null loop
938 if Is_In (Right.HT, Left_Node) then
941 Left_Node := HT_Ops.Next (Left.HT, Left_Node);
951 procedure Query_Element
953 Process : not null access procedure (Element : Element_Type))
956 if Position.Node = null then
957 raise Constraint_Error with
958 "Position cursor of Query_Element equals No_Element";
961 pragma Assert (Vet (Position), "bad cursor in Query_Element");
964 HT : Hash_Table_Type renames Position.Container.HT;
966 B : Natural renames HT.Busy;
967 L : Natural renames HT.Lock;
974 Process (Position.Node.Element);
992 (Stream : access Root_Stream_Type'Class;
996 Read_Nodes (Stream, Container.HT);
1000 (Stream : access Root_Stream_Type'Class;
1004 raise Program_Error with "attempt to stream set cursor";
1011 function Read_Node (Stream : access Root_Stream_Type'Class)
1014 Node : Node_Access := new Node_Type;
1017 Element_Type'Read (Stream, Node.Element);
1030 (Container : in out Set;
1031 New_Item : Element_Type)
1033 Node : constant Node_Access :=
1034 Element_Keys.Find (Container.HT, New_Item);
1038 raise Constraint_Error with
1039 "attempt to replace element not in set";
1042 if Container.HT.Lock > 0 then
1043 raise Program_Error with
1044 "attempt to tamper with cursors (set is locked)";
1047 Node.Element := New_Item;
1050 ---------------------
1051 -- Replace_Element --
1052 ---------------------
1054 procedure Replace_Element
1055 (HT : in out Hash_Table_Type;
1057 New_Item : Element_Type)
1060 if Equivalent_Elements (Node.Element, New_Item) then
1061 pragma Assert (Hash (Node.Element) = Hash (New_Item));
1064 raise Program_Error with
1065 "attempt to tamper with cursors (set is locked)";
1068 Node.Element := New_Item; -- Note that this assignment can fail
1073 raise Program_Error with
1074 "attempt to tamper with elements (set is busy)";
1077 HT_Ops.Delete_Node_Sans_Free (HT, Node);
1079 Insert_New_Element : declare
1080 function New_Node (Next : Node_Access) return Node_Access;
1081 pragma Inline (New_Node);
1083 procedure Local_Insert is
1084 new Element_Keys.Generic_Conditional_Insert (New_Node);
1090 function New_Node (Next : Node_Access) return Node_Access is
1092 Node.Element := New_Item; -- Note that this assignment can fail
1097 Result : Node_Access;
1100 -- Start of processing for Insert_New_Element
1107 Inserted => Inserted);
1114 null; -- Assignment must have failed
1115 end Insert_New_Element;
1117 Reinsert_Old_Element : declare
1118 function New_Node (Next : Node_Access) return Node_Access;
1119 pragma Inline (New_Node);
1121 procedure Local_Insert is
1122 new Element_Keys.Generic_Conditional_Insert (New_Node);
1128 function New_Node (Next : Node_Access) return Node_Access is
1134 Result : Node_Access;
1137 -- Start of processing for Reinsert_Old_Element
1142 Key => Node.Element,
1144 Inserted => Inserted);
1148 end Reinsert_Old_Element;
1150 raise Program_Error with "attempt to replace existing element";
1151 end Replace_Element;
1153 procedure Replace_Element
1154 (Container : in out Set;
1156 New_Item : Element_Type)
1159 if Position.Node = null then
1160 raise Constraint_Error with
1161 "Position cursor equals No_Element";
1164 if Position.Container /= Container'Unrestricted_Access then
1165 raise Program_Error with
1166 "Position cursor designates wrong set";
1169 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1171 Replace_Element (Container.HT, Position.Node, New_Item);
1172 end Replace_Element;
1174 ----------------------
1175 -- Reserve_Capacity --
1176 ----------------------
1178 procedure Reserve_Capacity
1179 (Container : in out Set;
1180 Capacity : Count_Type)
1183 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1184 end Reserve_Capacity;
1190 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1195 --------------------------
1196 -- Symmetric_Difference --
1197 --------------------------
1199 procedure Symmetric_Difference
1200 (Target : in out Set;
1204 if Target'Address = Source'Address then
1209 if Target.HT.Busy > 0 then
1210 raise Program_Error with
1211 "attempt to tamper with elements (set is busy)";
1215 N : constant Count_Type := Target.Length + Source.Length;
1217 if N > HT_Ops.Capacity (Target.HT) then
1218 HT_Ops.Reserve_Capacity (Target.HT, N);
1222 if Target.Length = 0 then
1223 Iterate_Source_When_Empty_Target : declare
1224 procedure Process (Src_Node : Node_Access);
1226 procedure Iterate is
1227 new HT_Ops.Generic_Iteration (Process);
1233 procedure Process (Src_Node : Node_Access) is
1234 E : Element_Type renames Src_Node.Element;
1235 B : Buckets_Type renames Target.HT.Buckets.all;
1236 J : constant Hash_Type := Hash (E) mod B'Length;
1237 N : Count_Type renames Target.HT.Length;
1240 B (J) := new Node_Type'(E, B (J));
1244 -- Start of processing for Iterate_Source_When_Empty_Target
1247 Iterate (Source.HT);
1248 end Iterate_Source_When_Empty_Target;
1251 Iterate_Source : declare
1252 procedure Process (Src_Node : Node_Access);
1254 procedure Iterate is
1255 new HT_Ops.Generic_Iteration (Process);
1261 procedure Process (Src_Node : Node_Access) is
1262 E : Element_Type renames Src_Node.Element;
1263 B : Buckets_Type renames Target.HT.Buckets.all;
1264 J : constant Hash_Type := Hash (E) mod B'Length;
1265 N : Count_Type renames Target.HT.Length;
1268 if B (J) = null then
1269 B (J) := new Node_Type'(E, null);
1272 elsif Equivalent_Elements (E, B (J).Element) then
1274 X : Node_Access := B (J);
1276 B (J) := B (J).Next;
1283 Prev : Node_Access := B (J);
1284 Curr : Node_Access := Prev.Next;
1287 while Curr /= null loop
1288 if Equivalent_Elements (E, Curr.Element) then
1289 Prev.Next := Curr.Next;
1299 B (J) := new Node_Type'(E, B (J));
1305 -- Start of processing for Iterate_Source
1308 Iterate (Source.HT);
1311 end Symmetric_Difference;
1313 function Symmetric_Difference (Left, Right : Set) return Set is
1314 Buckets : HT_Types.Buckets_Access;
1315 Length : Count_Type;
1318 if Left'Address = Right'Address then
1322 if Right.Length = 0 then
1326 if Left.Length = 0 then
1331 Size : constant Hash_Type :=
1332 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1334 Buckets := new Buckets_Type (0 .. Size - 1);
1339 Iterate_Left : declare
1340 procedure Process (L_Node : Node_Access);
1342 procedure Iterate is
1343 new HT_Ops.Generic_Iteration (Process);
1349 procedure Process (L_Node : Node_Access) is
1351 if not Is_In (Right.HT, L_Node) then
1353 E : Element_Type renames L_Node.Element;
1354 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1357 Buckets (J) := new Node_Type'(E, Buckets (J));
1358 Length := Length + 1;
1363 -- Start of processing for Iterate_Left
1369 HT_Ops.Free_Hash_Table (Buckets);
1373 Iterate_Right : declare
1374 procedure Process (R_Node : Node_Access);
1376 procedure Iterate is
1377 new HT_Ops.Generic_Iteration (Process);
1383 procedure Process (R_Node : Node_Access) is
1385 if not Is_In (Left.HT, R_Node) then
1387 E : Element_Type renames R_Node.Element;
1388 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1391 Buckets (J) := new Node_Type'(E, Buckets (J));
1392 Length := Length + 1;
1397 -- Start of processing for Iterate_Right
1403 HT_Ops.Free_Hash_Table (Buckets);
1407 return (Controlled with HT => (Buckets, Length, 0, 0));
1408 end Symmetric_Difference;
1414 function To_Set (New_Item : Element_Type) return Set is
1415 HT : Hash_Table_Type;
1420 Insert (HT, New_Item, Node, Inserted);
1421 return Set'(Controlled with HT);
1429 (Target : in out Set;
1432 procedure Process (Src_Node : Node_Access);
1434 procedure Iterate is
1435 new HT_Ops.Generic_Iteration (Process);
1441 procedure Process (Src_Node : Node_Access) is
1442 function New_Node (Next : Node_Access) return Node_Access;
1443 pragma Inline (New_Node);
1446 new Element_Keys.Generic_Conditional_Insert (New_Node);
1452 function New_Node (Next : Node_Access) return Node_Access is
1453 Node : constant Node_Access :=
1454 new Node_Type'(Src_Node.Element, Next);
1459 Tgt_Node : Node_Access;
1462 -- Start of processing for Process
1465 Insert (Target.HT, Src_Node.Element, Tgt_Node, Success);
1468 -- Start of processing for Union
1471 if Target'Address = Source'Address then
1475 if Target.HT.Busy > 0 then
1476 raise Program_Error with
1477 "attempt to tamper with elements (set is busy)";
1481 N : constant Count_Type := Target.Length + Source.Length;
1483 if N > HT_Ops.Capacity (Target.HT) then
1484 HT_Ops.Reserve_Capacity (Target.HT, N);
1488 Iterate (Source.HT);
1491 function Union (Left, Right : Set) return Set is
1492 Buckets : HT_Types.Buckets_Access;
1493 Length : Count_Type;
1496 if Left'Address = Right'Address then
1500 if Right.Length = 0 then
1504 if Left.Length = 0 then
1509 Size : constant Hash_Type :=
1510 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1512 Buckets := new Buckets_Type (0 .. Size - 1);
1515 Iterate_Left : declare
1516 procedure Process (L_Node : Node_Access);
1518 procedure Iterate is
1519 new HT_Ops.Generic_Iteration (Process);
1525 procedure Process (L_Node : Node_Access) is
1526 J : constant Hash_Type :=
1527 Hash (L_Node.Element) mod Buckets'Length;
1530 Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J));
1533 -- Start of processing for Iterate_Left
1539 HT_Ops.Free_Hash_Table (Buckets);
1543 Length := Left.Length;
1545 Iterate_Right : declare
1546 procedure Process (Src_Node : Node_Access);
1548 procedure Iterate is
1549 new HT_Ops.Generic_Iteration (Process);
1555 procedure Process (Src_Node : Node_Access) is
1556 J : constant Hash_Type :=
1557 Hash (Src_Node.Element) mod Buckets'Length;
1559 Tgt_Node : Node_Access := Buckets (J);
1562 while Tgt_Node /= null loop
1563 if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1567 Tgt_Node := Next (Tgt_Node);
1570 Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J));
1571 Length := Length + 1;
1574 -- Start of processing for Iterate_Right
1580 HT_Ops.Free_Hash_Table (Buckets);
1584 return (Controlled with HT => (Buckets, Length, 0, 0));
1591 function Vet (Position : Cursor) return Boolean is
1593 if Position.Node = null then
1594 return Position.Container = null;
1597 if Position.Container = null then
1601 if Position.Node.Next = Position.Node then
1606 HT : Hash_Table_Type renames Position.Container.HT;
1610 if HT.Length = 0 then
1614 if HT.Buckets = null
1615 or else HT.Buckets'Length = 0
1620 X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element));
1622 for J in 1 .. HT.Length loop
1623 if X = Position.Node then
1631 if X = X.Next then -- to prevent unnecessary looping
1647 (Stream : access Root_Stream_Type'Class;
1651 Write_Nodes (Stream, Container.HT);
1655 (Stream : access Root_Stream_Type'Class;
1659 raise Program_Error with "attempt to stream set cursor";
1666 procedure Write_Node
1667 (Stream : access Root_Stream_Type'Class;
1671 Element_Type'Write (Stream, Node.Element);
1674 package body Generic_Keys is
1676 -----------------------
1677 -- Local Subprograms --
1678 -----------------------
1680 function Equivalent_Key_Node
1682 Node : Node_Access) return Boolean;
1683 pragma Inline (Equivalent_Key_Node);
1685 --------------------------
1686 -- Local Instantiations --
1687 --------------------------
1690 new Hash_Tables.Generic_Keys
1691 (HT_Types => HT_Types,
1693 Set_Next => Set_Next,
1694 Key_Type => Key_Type,
1696 Equivalent_Keys => Equivalent_Key_Node);
1704 Key : Key_Type) return Boolean
1707 return Find (Container, Key) /= No_Element;
1715 (Container : in out Set;
1721 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1724 raise Constraint_Error with "attempt to delete key not in set";
1736 Key : Key_Type) return Element_Type
1738 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1742 raise Constraint_Error with "key not in map";
1745 return Node.Element;
1748 -------------------------
1749 -- Equivalent_Key_Node --
1750 -------------------------
1752 function Equivalent_Key_Node
1754 Node : Node_Access) return Boolean
1757 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1758 end Equivalent_Key_Node;
1765 (Container : in out Set;
1770 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1780 Key : Key_Type) return Cursor
1782 Node : constant Node_Access :=
1783 Key_Keys.Find (Container.HT, Key);
1790 return Cursor'(Container'Unrestricted_Access, Node);
1797 function Key (Position : Cursor) return Key_Type is
1799 if Position.Node = null then
1800 raise Constraint_Error with
1801 "Position cursor equals No_Element";
1804 pragma Assert (Vet (Position), "bad cursor in function Key");
1806 return Key (Position.Node.Element);
1814 (Container : in out Set;
1816 New_Item : Element_Type)
1818 Node : constant Node_Access :=
1819 Key_Keys.Find (Container.HT, Key);
1823 raise Constraint_Error with
1824 "attempt to replace key not in set";
1827 Replace_Element (Container.HT, Node, New_Item);
1830 -----------------------------------
1831 -- Update_Element_Preserving_Key --
1832 -----------------------------------
1834 procedure Update_Element_Preserving_Key
1835 (Container : in out Set;
1837 Process : not null access
1838 procedure (Element : in out Element_Type))
1840 HT : Hash_Table_Type renames Container.HT;
1844 if Position.Node = null then
1845 raise Constraint_Error with
1846 "Position cursor equals No_Element";
1849 if Position.Container /= Container'Unrestricted_Access then
1850 raise Program_Error with
1851 "Position cursor designates wrong set";
1854 if HT.Buckets = null
1855 or else HT.Buckets'Length = 0
1856 or else HT.Length = 0
1857 or else Position.Node.Next = Position.Node
1859 raise Program_Error with "Position cursor is bad (set is empty)";
1864 "bad cursor in Update_Element_Preserving_Key");
1866 Indx := HT_Ops.Index (HT, Position.Node);
1869 E : Element_Type renames Position.Node.Element;
1870 K : constant Key_Type := Key (E);
1872 B : Natural renames HT.Busy;
1873 L : Natural renames HT.Lock;
1891 if Equivalent_Keys (K, Key (E)) then
1892 pragma Assert (Hash (K) = Hash (E));
1897 if HT.Buckets (Indx) = Position.Node then
1898 HT.Buckets (Indx) := Position.Node.Next;
1902 Prev : Node_Access := HT.Buckets (Indx);
1905 while Prev.Next /= Position.Node loop
1909 raise Program_Error with
1910 "Position cursor is bad (node not found)";
1914 Prev.Next := Position.Node.Next;
1918 HT.Length := HT.Length - 1;
1921 X : Node_Access := Position.Node;
1927 raise Program_Error with "key was modified";
1928 end Update_Element_Preserving_Key;
1932 end Ada.Containers.Hashed_Sets;