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-2006, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- This unit has originally being developed by Matthew J Heaney. --
30 ------------------------------------------------------------------------------
32 with Ada.Unchecked_Deallocation;
34 with Ada.Containers.Hash_Tables.Generic_Operations;
35 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
37 with Ada.Containers.Hash_Tables.Generic_Keys;
38 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
40 with Ada.Containers.Prime_Numbers;
42 with System; use type System.Address;
44 package body Ada.Containers.Hashed_Sets is
46 -----------------------
47 -- Local Subprograms --
48 -----------------------
50 procedure Assign (Node : Node_Access; Item : Element_Type);
51 pragma Inline (Assign);
53 function Copy_Node (Source : Node_Access) return Node_Access;
54 pragma Inline (Copy_Node);
56 function Equivalent_Keys
58 Node : Node_Access) return Boolean;
59 pragma Inline (Equivalent_Keys);
61 function Find_Equal_Key
62 (R_HT : Hash_Table_Type;
63 L_Node : Node_Access) return Boolean;
65 function Find_Equivalent_Key
66 (R_HT : Hash_Table_Type;
67 L_Node : Node_Access) return Boolean;
69 procedure Free (X : in out Node_Access);
71 function Hash_Node (Node : Node_Access) return Hash_Type;
72 pragma Inline (Hash_Node);
75 (HT : in out Hash_Table_Type;
76 New_Item : Element_Type;
77 Node : out Node_Access;
78 Inserted : out Boolean);
81 (HT : Hash_Table_Type;
82 Key : Node_Access) return Boolean;
83 pragma Inline (Is_In);
85 function Next (Node : Node_Access) return Node_Access;
88 function Read_Node (Stream : not null access Root_Stream_Type'Class)
90 pragma Inline (Read_Node);
92 procedure Set_Next (Node : Node_Access; Next : Node_Access);
93 pragma Inline (Set_Next);
95 function Vet (Position : Cursor) return Boolean;
98 (Stream : not null access Root_Stream_Type'Class;
100 pragma Inline (Write_Node);
102 --------------------------
103 -- Local Instantiations --
104 --------------------------
107 new Hash_Tables.Generic_Operations
108 (HT_Types => HT_Types,
109 Hash_Node => Hash_Node,
111 Set_Next => Set_Next,
112 Copy_Node => Copy_Node,
115 package Element_Keys is
116 new Hash_Tables.Generic_Keys
117 (HT_Types => HT_Types,
119 Set_Next => Set_Next,
120 Key_Type => Element_Type,
122 Equivalent_Keys => Equivalent_Keys);
125 new HT_Ops.Generic_Equal (Find_Equal_Key);
127 function Is_Equivalent is
128 new HT_Ops.Generic_Equal (Find_Equivalent_Key);
130 procedure Read_Nodes is
131 new HT_Ops.Generic_Read (Read_Node);
133 procedure Replace_Element is
134 new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
136 procedure Write_Nodes is
137 new HT_Ops.Generic_Write (Write_Node);
143 function "=" (Left, Right : Set) return Boolean is
145 return Is_Equal (Left.HT, Right.HT);
152 procedure Adjust (Container : in out Set) is
154 HT_Ops.Adjust (Container.HT);
161 procedure Assign (Node : Node_Access; Item : Element_Type) is
163 Node.Element := Item;
170 function Capacity (Container : Set) return Count_Type is
172 return HT_Ops.Capacity (Container.HT);
179 procedure Clear (Container : in out Set) is
181 HT_Ops.Clear (Container.HT);
188 function Contains (Container : Set; Item : Element_Type) return Boolean is
190 return Find (Container, Item) /= No_Element;
197 function Copy_Node (Source : Node_Access) return Node_Access is
199 return new Node_Type'(Element => Source.Element, Next => null);
207 (Container : in out Set;
213 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
216 raise Constraint_Error with "attempt to delete element not in set";
223 (Container : in out Set;
224 Position : in out Cursor)
227 if Position.Node = null then
228 raise Constraint_Error with "Position cursor equals No_Element";
231 if Position.Container /= Container'Unrestricted_Access then
232 raise Program_Error with "Position cursor designates wrong set";
235 if Container.HT.Busy > 0 then
236 raise Program_Error with
237 "attempt to tamper with elements (set is busy)";
240 pragma Assert (Vet (Position), "bad cursor in Delete");
242 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
244 Free (Position.Node);
245 Position.Container := null;
253 (Target : in out Set;
256 Tgt_Node : Node_Access;
259 if Target'Address = Source'Address then
264 if Source.HT.Length = 0 then
268 if Target.HT.Busy > 0 then
269 raise Program_Error with
270 "attempt to tamper with elements (set is busy)";
273 if Source.HT.Length < Target.HT.Length then
275 Src_Node : Node_Access;
278 Src_Node := HT_Ops.First (Source.HT);
279 while Src_Node /= null loop
280 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element);
282 if Tgt_Node /= null then
283 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
287 Src_Node := HT_Ops.Next (Source.HT, Src_Node);
292 Tgt_Node := HT_Ops.First (Target.HT);
293 while Tgt_Node /= null loop
294 if Is_In (Source.HT, Tgt_Node) then
296 X : Node_Access := Tgt_Node;
298 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
299 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
304 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
310 function Difference (Left, Right : Set) return Set is
311 Buckets : HT_Types.Buckets_Access;
315 if Left'Address = Right'Address then
319 if Left.HT.Length = 0 then
323 if Right.HT.Length = 0 then
328 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
330 Buckets := new Buckets_Type (0 .. Size - 1);
335 Iterate_Left : declare
336 procedure Process (L_Node : Node_Access);
339 new HT_Ops.Generic_Iteration (Process);
345 procedure Process (L_Node : Node_Access) is
347 if not Is_In (Right.HT, L_Node) then
349 J : constant Hash_Type :=
350 Hash (L_Node.Element) mod Buckets'Length;
352 Bucket : Node_Access renames Buckets (J);
355 Bucket := new Node_Type'(L_Node.Element, Bucket);
358 Length := Length + 1;
362 -- Start of processing for Iterate_Left
368 HT_Ops.Free_Hash_Table (Buckets);
372 return (Controlled with HT => (Buckets, Length, 0, 0));
379 function Element (Position : Cursor) return Element_Type is
381 if Position.Node = null then
382 raise Constraint_Error with "Position cursor equals No_Element";
385 pragma Assert (Vet (Position), "bad cursor in function Element");
387 return Position.Node.Element;
390 ---------------------
391 -- Equivalent_Sets --
392 ---------------------
394 function Equivalent_Sets (Left, Right : Set) return Boolean is
396 return Is_Equivalent (Left.HT, Right.HT);
399 -------------------------
400 -- Equivalent_Elements --
401 -------------------------
403 function Equivalent_Elements (Left, Right : Cursor)
406 if Left.Node = null then
407 raise Constraint_Error with
408 "Left cursor of Equivalent_Elements equals No_Element";
411 if Right.Node = null then
412 raise Constraint_Error with
413 "Right cursor of Equivalent_Elements equals No_Element";
416 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
417 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
419 return Equivalent_Elements (Left.Node.Element, Right.Node.Element);
420 end Equivalent_Elements;
422 function Equivalent_Elements (Left : Cursor; Right : Element_Type)
425 if Left.Node = null then
426 raise Constraint_Error with
427 "Left cursor of Equivalent_Elements equals No_Element";
430 pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad");
432 return Equivalent_Elements (Left.Node.Element, Right);
433 end Equivalent_Elements;
435 function Equivalent_Elements (Left : Element_Type; Right : Cursor)
438 if Right.Node = null then
439 raise Constraint_Error with
440 "Right cursor of Equivalent_Elements equals No_Element";
445 "Right cursor of Equivalent_Elements is bad");
447 return Equivalent_Elements (Left, Right.Node.Element);
448 end Equivalent_Elements;
450 ---------------------
451 -- Equivalent_Keys --
452 ---------------------
454 function Equivalent_Keys (Key : Element_Type; Node : Node_Access)
457 return Equivalent_Elements (Key, Node.Element);
465 (Container : in out Set;
470 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
478 procedure Finalize (Container : in out Set) is
480 HT_Ops.Finalize (Container.HT);
489 Item : Element_Type) return Cursor
491 Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
498 return Cursor'(Container'Unrestricted_Access, Node);
505 function Find_Equal_Key
506 (R_HT : Hash_Table_Type;
507 L_Node : Node_Access) return Boolean
509 R_Index : constant Hash_Type :=
510 Element_Keys.Index (R_HT, L_Node.Element);
512 R_Node : Node_Access := R_HT.Buckets (R_Index);
516 if R_Node = null then
520 if L_Node.Element = R_Node.Element then
524 R_Node := Next (R_Node);
528 -------------------------
529 -- Find_Equivalent_Key --
530 -------------------------
532 function Find_Equivalent_Key
533 (R_HT : Hash_Table_Type;
534 L_Node : Node_Access) return Boolean
536 R_Index : constant Hash_Type :=
537 Element_Keys.Index (R_HT, L_Node.Element);
539 R_Node : Node_Access := R_HT.Buckets (R_Index);
543 if R_Node = null then
547 if Equivalent_Elements (L_Node.Element, R_Node.Element) then
551 R_Node := Next (R_Node);
553 end Find_Equivalent_Key;
559 function First (Container : Set) return Cursor is
560 Node : constant Node_Access := HT_Ops.First (Container.HT);
567 return Cursor'(Container'Unrestricted_Access, Node);
574 procedure Free (X : in out Node_Access) is
575 procedure Deallocate is
576 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
580 X.Next := X; -- detect mischief (in Vet)
589 function Has_Element (Position : Cursor) return Boolean is
591 pragma Assert (Vet (Position), "bad cursor in Has_Element");
592 return Position.Node /= null;
599 function Hash_Node (Node : Node_Access) return Hash_Type is
601 return Hash (Node.Element);
609 (Container : in out Set;
610 New_Item : Element_Type)
616 Insert (Container, New_Item, Position, Inserted);
619 if Container.HT.Lock > 0 then
620 raise Program_Error with
621 "attempt to tamper with cursors (set is locked)";
624 Position.Node.Element := New_Item;
633 (Container : in out Set;
634 New_Item : Element_Type;
635 Position : out Cursor;
636 Inserted : out Boolean)
639 Insert (Container.HT, New_Item, Position.Node, Inserted);
640 Position.Container := Container'Unchecked_Access;
644 (Container : in out Set;
645 New_Item : Element_Type)
651 Insert (Container, New_Item, Position, Inserted);
654 raise Constraint_Error with
655 "attempt to insert element already in set";
660 (HT : in out Hash_Table_Type;
661 New_Item : Element_Type;
662 Node : out Node_Access;
663 Inserted : out Boolean)
665 function New_Node (Next : Node_Access) return Node_Access;
666 pragma Inline (New_Node);
668 procedure Local_Insert is
669 new Element_Keys.Generic_Conditional_Insert (New_Node);
675 function New_Node (Next : Node_Access) return Node_Access is
677 return new Node_Type'(New_Item, Next);
680 -- Start of processing for Insert
683 if HT_Ops.Capacity (HT) = 0 then
684 HT_Ops.Reserve_Capacity (HT, 1);
687 Local_Insert (HT, New_Item, Node, Inserted);
690 and then HT.Length > HT_Ops.Capacity (HT)
692 HT_Ops.Reserve_Capacity (HT, HT.Length);
700 procedure Intersection
701 (Target : in out Set;
704 Tgt_Node : Node_Access;
707 if Target'Address = Source'Address then
711 if Source.HT.Length = 0 then
716 if Target.HT.Busy > 0 then
717 raise Program_Error with
718 "attempt to tamper with elements (set is busy)";
721 Tgt_Node := HT_Ops.First (Target.HT);
722 while Tgt_Node /= null loop
723 if Is_In (Source.HT, Tgt_Node) then
724 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
728 X : Node_Access := Tgt_Node;
730 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
731 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
738 function Intersection (Left, Right : Set) return Set is
739 Buckets : HT_Types.Buckets_Access;
743 if Left'Address = Right'Address then
747 Length := Count_Type'Min (Left.Length, Right.Length);
754 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
756 Buckets := new Buckets_Type (0 .. Size - 1);
761 Iterate_Left : declare
762 procedure Process (L_Node : Node_Access);
765 new HT_Ops.Generic_Iteration (Process);
771 procedure Process (L_Node : Node_Access) is
773 if Is_In (Right.HT, L_Node) then
775 J : constant Hash_Type :=
776 Hash (L_Node.Element) mod Buckets'Length;
778 Bucket : Node_Access renames Buckets (J);
781 Bucket := new Node_Type'(L_Node.Element, Bucket);
784 Length := Length + 1;
788 -- Start of processing for Iterate_Left
794 HT_Ops.Free_Hash_Table (Buckets);
798 return (Controlled with HT => (Buckets, Length, 0, 0));
805 function Is_Empty (Container : Set) return Boolean is
807 return Container.HT.Length = 0;
814 function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
816 return Element_Keys.Find (HT, Key.Element) /= null;
823 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
824 Subset_Node : Node_Access;
827 if Subset'Address = Of_Set'Address then
831 if Subset.Length > Of_Set.Length then
835 Subset_Node := HT_Ops.First (Subset.HT);
836 while Subset_Node /= null loop
837 if not Is_In (Of_Set.HT, Subset_Node) then
840 Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
852 Process : not null access procedure (Position : Cursor))
854 procedure Process_Node (Node : Node_Access);
855 pragma Inline (Process_Node);
858 new HT_Ops.Generic_Iteration (Process_Node);
864 procedure Process_Node (Node : Node_Access) is
866 Process (Cursor'(Container'Unrestricted_Access, Node));
869 B : Natural renames Container'Unrestricted_Access.HT.Busy;
871 -- Start of processing for Iterate
877 Iterate (Container.HT);
891 function Length (Container : Set) return Count_Type is
893 return Container.HT.Length;
900 procedure Move (Target : in out Set; Source : in out Set) is
902 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
909 function Next (Node : Node_Access) return Node_Access is
914 function Next (Position : Cursor) return Cursor is
916 if Position.Node = null then
920 pragma Assert (Vet (Position), "bad cursor in Next");
923 HT : Hash_Table_Type renames Position.Container.HT;
924 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
931 return Cursor'(Position.Container, Node);
935 procedure Next (Position : in out Cursor) is
937 Position := Next (Position);
944 function Overlap (Left, Right : Set) return Boolean is
945 Left_Node : Node_Access;
948 if Right.Length = 0 then
952 if Left'Address = Right'Address then
956 Left_Node := HT_Ops.First (Left.HT);
957 while Left_Node /= null loop
958 if Is_In (Right.HT, Left_Node) then
961 Left_Node := HT_Ops.Next (Left.HT, Left_Node);
971 procedure Query_Element
973 Process : not null access procedure (Element : Element_Type))
976 if Position.Node = null then
977 raise Constraint_Error with
978 "Position cursor of Query_Element equals No_Element";
981 pragma Assert (Vet (Position), "bad cursor in Query_Element");
984 HT : Hash_Table_Type renames Position.Container.HT;
986 B : Natural renames HT.Busy;
987 L : Natural renames HT.Lock;
994 Process (Position.Node.Element);
1012 (Stream : not null access Root_Stream_Type'Class;
1013 Container : out Set)
1016 Read_Nodes (Stream, Container.HT);
1020 (Stream : not null access Root_Stream_Type'Class;
1024 raise Program_Error with "attempt to stream set cursor";
1031 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1034 Node : Node_Access := new Node_Type;
1037 Element_Type'Read (Stream, Node.Element);
1050 (Container : in out Set;
1051 New_Item : Element_Type)
1053 Node : constant Node_Access :=
1054 Element_Keys.Find (Container.HT, New_Item);
1058 raise Constraint_Error with
1059 "attempt to replace element not in set";
1062 if Container.HT.Lock > 0 then
1063 raise Program_Error with
1064 "attempt to tamper with cursors (set is locked)";
1067 Node.Element := New_Item;
1070 procedure Replace_Element
1071 (Container : in out Set;
1073 New_Item : Element_Type)
1076 if Position.Node = null then
1077 raise Constraint_Error with
1078 "Position cursor equals No_Element";
1081 if Position.Container /= Container'Unrestricted_Access then
1082 raise Program_Error with
1083 "Position cursor designates wrong set";
1086 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1088 Replace_Element (Container.HT, Position.Node, New_Item);
1089 end Replace_Element;
1091 ----------------------
1092 -- Reserve_Capacity --
1093 ----------------------
1095 procedure Reserve_Capacity
1096 (Container : in out Set;
1097 Capacity : Count_Type)
1100 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1101 end Reserve_Capacity;
1107 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1112 --------------------------
1113 -- Symmetric_Difference --
1114 --------------------------
1116 procedure Symmetric_Difference
1117 (Target : in out Set;
1121 if Target'Address = Source'Address then
1126 if Target.HT.Busy > 0 then
1127 raise Program_Error with
1128 "attempt to tamper with elements (set is busy)";
1132 N : constant Count_Type := Target.Length + Source.Length;
1134 if N > HT_Ops.Capacity (Target.HT) then
1135 HT_Ops.Reserve_Capacity (Target.HT, N);
1139 if Target.Length = 0 then
1140 Iterate_Source_When_Empty_Target : declare
1141 procedure Process (Src_Node : Node_Access);
1143 procedure Iterate is
1144 new HT_Ops.Generic_Iteration (Process);
1150 procedure Process (Src_Node : Node_Access) is
1151 E : Element_Type renames Src_Node.Element;
1152 B : Buckets_Type renames Target.HT.Buckets.all;
1153 J : constant Hash_Type := Hash (E) mod B'Length;
1154 N : Count_Type renames Target.HT.Length;
1157 B (J) := new Node_Type'(E, B (J));
1161 -- Start of processing for Iterate_Source_When_Empty_Target
1164 Iterate (Source.HT);
1165 end Iterate_Source_When_Empty_Target;
1168 Iterate_Source : declare
1169 procedure Process (Src_Node : Node_Access);
1171 procedure Iterate is
1172 new HT_Ops.Generic_Iteration (Process);
1178 procedure Process (Src_Node : Node_Access) is
1179 E : Element_Type renames Src_Node.Element;
1180 B : Buckets_Type renames Target.HT.Buckets.all;
1181 J : constant Hash_Type := Hash (E) mod B'Length;
1182 N : Count_Type renames Target.HT.Length;
1185 if B (J) = null then
1186 B (J) := new Node_Type'(E, null);
1189 elsif Equivalent_Elements (E, B (J).Element) then
1191 X : Node_Access := B (J);
1193 B (J) := B (J).Next;
1200 Prev : Node_Access := B (J);
1201 Curr : Node_Access := Prev.Next;
1204 while Curr /= null loop
1205 if Equivalent_Elements (E, Curr.Element) then
1206 Prev.Next := Curr.Next;
1216 B (J) := new Node_Type'(E, B (J));
1222 -- Start of processing for Iterate_Source
1225 Iterate (Source.HT);
1228 end Symmetric_Difference;
1230 function Symmetric_Difference (Left, Right : Set) return Set is
1231 Buckets : HT_Types.Buckets_Access;
1232 Length : Count_Type;
1235 if Left'Address = Right'Address then
1239 if Right.Length = 0 then
1243 if Left.Length = 0 then
1248 Size : constant Hash_Type :=
1249 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1251 Buckets := new Buckets_Type (0 .. Size - 1);
1256 Iterate_Left : declare
1257 procedure Process (L_Node : Node_Access);
1259 procedure Iterate is
1260 new HT_Ops.Generic_Iteration (Process);
1266 procedure Process (L_Node : Node_Access) is
1268 if not Is_In (Right.HT, L_Node) then
1270 E : Element_Type renames L_Node.Element;
1271 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1274 Buckets (J) := new Node_Type'(E, Buckets (J));
1275 Length := Length + 1;
1280 -- Start of processing for Iterate_Left
1286 HT_Ops.Free_Hash_Table (Buckets);
1290 Iterate_Right : declare
1291 procedure Process (R_Node : Node_Access);
1293 procedure Iterate is
1294 new HT_Ops.Generic_Iteration (Process);
1300 procedure Process (R_Node : Node_Access) is
1302 if not Is_In (Left.HT, R_Node) then
1304 E : Element_Type renames R_Node.Element;
1305 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1308 Buckets (J) := new Node_Type'(E, Buckets (J));
1309 Length := Length + 1;
1314 -- Start of processing for Iterate_Right
1320 HT_Ops.Free_Hash_Table (Buckets);
1324 return (Controlled with HT => (Buckets, Length, 0, 0));
1325 end Symmetric_Difference;
1331 function To_Set (New_Item : Element_Type) return Set is
1332 HT : Hash_Table_Type;
1337 Insert (HT, New_Item, Node, Inserted);
1338 return Set'(Controlled with HT);
1346 (Target : in out Set;
1349 procedure Process (Src_Node : Node_Access);
1351 procedure Iterate is
1352 new HT_Ops.Generic_Iteration (Process);
1358 procedure Process (Src_Node : Node_Access) is
1359 function New_Node (Next : Node_Access) return Node_Access;
1360 pragma Inline (New_Node);
1363 new Element_Keys.Generic_Conditional_Insert (New_Node);
1369 function New_Node (Next : Node_Access) return Node_Access is
1370 Node : constant Node_Access :=
1371 new Node_Type'(Src_Node.Element, Next);
1376 Tgt_Node : Node_Access;
1379 -- Start of processing for Process
1382 Insert (Target.HT, Src_Node.Element, Tgt_Node, Success);
1385 -- Start of processing for Union
1388 if Target'Address = Source'Address then
1392 if Target.HT.Busy > 0 then
1393 raise Program_Error with
1394 "attempt to tamper with elements (set is busy)";
1398 N : constant Count_Type := Target.Length + Source.Length;
1400 if N > HT_Ops.Capacity (Target.HT) then
1401 HT_Ops.Reserve_Capacity (Target.HT, N);
1405 Iterate (Source.HT);
1408 function Union (Left, Right : Set) return Set is
1409 Buckets : HT_Types.Buckets_Access;
1410 Length : Count_Type;
1413 if Left'Address = Right'Address then
1417 if Right.Length = 0 then
1421 if Left.Length = 0 then
1426 Size : constant Hash_Type :=
1427 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1429 Buckets := new Buckets_Type (0 .. Size - 1);
1432 Iterate_Left : declare
1433 procedure Process (L_Node : Node_Access);
1435 procedure Iterate is
1436 new HT_Ops.Generic_Iteration (Process);
1442 procedure Process (L_Node : Node_Access) is
1443 J : constant Hash_Type :=
1444 Hash (L_Node.Element) mod Buckets'Length;
1447 Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J));
1450 -- Start of processing for Iterate_Left
1456 HT_Ops.Free_Hash_Table (Buckets);
1460 Length := Left.Length;
1462 Iterate_Right : declare
1463 procedure Process (Src_Node : Node_Access);
1465 procedure Iterate is
1466 new HT_Ops.Generic_Iteration (Process);
1472 procedure Process (Src_Node : Node_Access) is
1473 J : constant Hash_Type :=
1474 Hash (Src_Node.Element) mod Buckets'Length;
1476 Tgt_Node : Node_Access := Buckets (J);
1479 while Tgt_Node /= null loop
1480 if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1484 Tgt_Node := Next (Tgt_Node);
1487 Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J));
1488 Length := Length + 1;
1491 -- Start of processing for Iterate_Right
1497 HT_Ops.Free_Hash_Table (Buckets);
1501 return (Controlled with HT => (Buckets, Length, 0, 0));
1508 function Vet (Position : Cursor) return Boolean is
1510 if Position.Node = null then
1511 return Position.Container = null;
1514 if Position.Container = null then
1518 if Position.Node.Next = Position.Node then
1523 HT : Hash_Table_Type renames Position.Container.HT;
1527 if HT.Length = 0 then
1531 if HT.Buckets = null
1532 or else HT.Buckets'Length = 0
1537 X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element));
1539 for J in 1 .. HT.Length loop
1540 if X = Position.Node then
1548 if X = X.Next then -- to prevent unnecessary looping
1564 (Stream : not null access Root_Stream_Type'Class;
1568 Write_Nodes (Stream, Container.HT);
1572 (Stream : not null access Root_Stream_Type'Class;
1576 raise Program_Error with "attempt to stream set cursor";
1583 procedure Write_Node
1584 (Stream : not null access Root_Stream_Type'Class;
1588 Element_Type'Write (Stream, Node.Element);
1591 package body Generic_Keys is
1593 -----------------------
1594 -- Local Subprograms --
1595 -----------------------
1597 function Equivalent_Key_Node
1599 Node : Node_Access) return Boolean;
1600 pragma Inline (Equivalent_Key_Node);
1602 --------------------------
1603 -- Local Instantiations --
1604 --------------------------
1607 new Hash_Tables.Generic_Keys
1608 (HT_Types => HT_Types,
1610 Set_Next => Set_Next,
1611 Key_Type => Key_Type,
1613 Equivalent_Keys => Equivalent_Key_Node);
1621 Key : Key_Type) return Boolean
1624 return Find (Container, Key) /= No_Element;
1632 (Container : in out Set;
1638 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1641 raise Constraint_Error with "attempt to delete key not in set";
1653 Key : Key_Type) return Element_Type
1655 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1659 raise Constraint_Error with "key not in map";
1662 return Node.Element;
1665 -------------------------
1666 -- Equivalent_Key_Node --
1667 -------------------------
1669 function Equivalent_Key_Node
1671 Node : Node_Access) return Boolean
1674 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1675 end Equivalent_Key_Node;
1682 (Container : in out Set;
1687 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1697 Key : Key_Type) return Cursor
1699 Node : constant Node_Access :=
1700 Key_Keys.Find (Container.HT, Key);
1707 return Cursor'(Container'Unrestricted_Access, Node);
1714 function Key (Position : Cursor) return Key_Type is
1716 if Position.Node = null then
1717 raise Constraint_Error with
1718 "Position cursor equals No_Element";
1721 pragma Assert (Vet (Position), "bad cursor in function Key");
1723 return Key (Position.Node.Element);
1731 (Container : in out Set;
1733 New_Item : Element_Type)
1735 Node : constant Node_Access :=
1736 Key_Keys.Find (Container.HT, Key);
1740 raise Constraint_Error with
1741 "attempt to replace key not in set";
1744 Replace_Element (Container.HT, Node, New_Item);
1747 -----------------------------------
1748 -- Update_Element_Preserving_Key --
1749 -----------------------------------
1751 procedure Update_Element_Preserving_Key
1752 (Container : in out Set;
1754 Process : not null access
1755 procedure (Element : in out Element_Type))
1757 HT : Hash_Table_Type renames Container.HT;
1761 if Position.Node = null then
1762 raise Constraint_Error with
1763 "Position cursor equals No_Element";
1766 if Position.Container /= Container'Unrestricted_Access then
1767 raise Program_Error with
1768 "Position cursor designates wrong set";
1771 if HT.Buckets = null
1772 or else HT.Buckets'Length = 0
1773 or else HT.Length = 0
1774 or else Position.Node.Next = Position.Node
1776 raise Program_Error with "Position cursor is bad (set is empty)";
1781 "bad cursor in Update_Element_Preserving_Key");
1783 Indx := HT_Ops.Index (HT, Position.Node);
1786 E : Element_Type renames Position.Node.Element;
1787 K : constant Key_Type := Key (E);
1789 B : Natural renames HT.Busy;
1790 L : Natural renames HT.Lock;
1808 if Equivalent_Keys (K, Key (E)) then
1809 pragma Assert (Hash (K) = Hash (E));
1814 if HT.Buckets (Indx) = Position.Node then
1815 HT.Buckets (Indx) := Position.Node.Next;
1819 Prev : Node_Access := HT.Buckets (Indx);
1822 while Prev.Next /= Position.Node loop
1826 raise Program_Error with
1827 "Position cursor is bad (node not found)";
1831 Prev.Next := Position.Node.Next;
1835 HT.Length := HT.Length - 1;
1838 X : Node_Access := Position.Node;
1844 raise Program_Error with "key was modified";
1845 end Update_Element_Preserving_Key;
1849 end Ada.Containers.Hashed_Sets;