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-2010, 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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada.Unchecked_Deallocation;
32 with Ada.Containers.Hash_Tables.Generic_Operations;
33 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
35 with Ada.Containers.Hash_Tables.Generic_Keys;
36 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
38 with Ada.Containers.Prime_Numbers;
40 with System; use type System.Address;
42 package body Ada.Containers.Hashed_Sets is
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
48 procedure Assign (Node : Node_Access; Item : Element_Type);
49 pragma Inline (Assign);
51 function Copy_Node (Source : Node_Access) return Node_Access;
52 pragma Inline (Copy_Node);
54 function Equivalent_Keys
56 Node : Node_Access) return Boolean;
57 pragma Inline (Equivalent_Keys);
59 function Find_Equal_Key
60 (R_HT : Hash_Table_Type;
61 L_Node : Node_Access) return Boolean;
63 function Find_Equivalent_Key
64 (R_HT : Hash_Table_Type;
65 L_Node : Node_Access) return Boolean;
67 procedure Free (X : in out Node_Access);
69 function Hash_Node (Node : Node_Access) return Hash_Type;
70 pragma Inline (Hash_Node);
73 (HT : in out Hash_Table_Type;
74 New_Item : Element_Type;
75 Node : out Node_Access;
76 Inserted : out Boolean);
79 (HT : Hash_Table_Type;
80 Key : Node_Access) return Boolean;
81 pragma Inline (Is_In);
83 function Next (Node : Node_Access) return Node_Access;
86 function Read_Node (Stream : not null access Root_Stream_Type'Class)
88 pragma Inline (Read_Node);
90 procedure Set_Next (Node : Node_Access; Next : Node_Access);
91 pragma Inline (Set_Next);
93 function Vet (Position : Cursor) return Boolean;
96 (Stream : not null access Root_Stream_Type'Class;
98 pragma Inline (Write_Node);
100 --------------------------
101 -- Local Instantiations --
102 --------------------------
104 package HT_Ops is new Hash_Tables.Generic_Operations
105 (HT_Types => HT_Types,
106 Hash_Node => Hash_Node,
108 Set_Next => Set_Next,
109 Copy_Node => Copy_Node,
112 package Element_Keys is new Hash_Tables.Generic_Keys
113 (HT_Types => HT_Types,
115 Set_Next => Set_Next,
116 Key_Type => Element_Type,
118 Equivalent_Keys => Equivalent_Keys);
121 new HT_Ops.Generic_Equal (Find_Equal_Key);
123 function Is_Equivalent is
124 new HT_Ops.Generic_Equal (Find_Equivalent_Key);
126 procedure Read_Nodes is
127 new HT_Ops.Generic_Read (Read_Node);
129 procedure Replace_Element is
130 new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
132 procedure Write_Nodes is
133 new HT_Ops.Generic_Write (Write_Node);
139 function "=" (Left, Right : Set) return Boolean is
141 return Is_Equal (Left.HT, Right.HT);
148 procedure Adjust (Container : in out Set) is
150 HT_Ops.Adjust (Container.HT);
157 procedure Assign (Node : Node_Access; Item : Element_Type) is
159 Node.Element := Item;
166 function Capacity (Container : Set) return Count_Type is
168 return HT_Ops.Capacity (Container.HT);
175 procedure Clear (Container : in out Set) is
177 HT_Ops.Clear (Container.HT);
184 function Contains (Container : Set; Item : Element_Type) return Boolean is
186 return Find (Container, Item) /= No_Element;
193 function Copy_Node (Source : Node_Access) return Node_Access is
195 return new Node_Type'(Element => Source.Element, Next => null);
203 (Container : in out Set;
209 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
212 raise Constraint_Error with "attempt to delete element not in set";
219 (Container : in out Set;
220 Position : in out Cursor)
223 if Position.Node = null then
224 raise Constraint_Error with "Position cursor equals No_Element";
227 if Position.Container /= Container'Unrestricted_Access then
228 raise Program_Error with "Position cursor designates wrong set";
231 if Container.HT.Busy > 0 then
232 raise Program_Error with
233 "attempt to tamper with cursors (set is busy)";
236 pragma Assert (Vet (Position), "bad cursor in Delete");
238 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
240 Free (Position.Node);
241 Position.Container := null;
249 (Target : in out Set;
252 Tgt_Node : Node_Access;
255 if Target'Address = Source'Address then
260 if Source.HT.Length = 0 then
264 if Target.HT.Busy > 0 then
265 raise Program_Error with
266 "attempt to tamper with cursors (set is busy)";
269 if Source.HT.Length < Target.HT.Length then
271 Src_Node : Node_Access;
274 Src_Node := HT_Ops.First (Source.HT);
275 while Src_Node /= null loop
276 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element);
278 if Tgt_Node /= null then
279 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
283 Src_Node := HT_Ops.Next (Source.HT, Src_Node);
288 Tgt_Node := HT_Ops.First (Target.HT);
289 while Tgt_Node /= null loop
290 if Is_In (Source.HT, Tgt_Node) then
292 X : Node_Access := Tgt_Node;
294 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
295 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
300 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
306 function Difference (Left, Right : Set) return Set is
307 Buckets : HT_Types.Buckets_Access;
311 if Left'Address = Right'Address then
315 if Left.HT.Length = 0 then
319 if Right.HT.Length = 0 then
324 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
326 Buckets := HT_Ops.New_Buckets (Length => Size);
331 Iterate_Left : declare
332 procedure Process (L_Node : Node_Access);
335 new HT_Ops.Generic_Iteration (Process);
341 procedure Process (L_Node : Node_Access) is
343 if not Is_In (Right.HT, L_Node) then
345 J : constant Hash_Type :=
346 Hash (L_Node.Element) mod Buckets'Length;
348 Bucket : Node_Access renames Buckets (J);
351 Bucket := new Node_Type'(L_Node.Element, Bucket);
354 Length := Length + 1;
358 -- Start of processing for Iterate_Left
364 HT_Ops.Free_Hash_Table (Buckets);
368 return (Controlled with HT => (Buckets, Length, 0, 0));
375 function Element (Position : Cursor) return Element_Type is
377 if Position.Node = null then
378 raise Constraint_Error with "Position cursor equals No_Element";
381 pragma Assert (Vet (Position), "bad cursor in function Element");
383 return Position.Node.Element;
386 ---------------------
387 -- Equivalent_Sets --
388 ---------------------
390 function Equivalent_Sets (Left, Right : Set) return Boolean is
392 return Is_Equivalent (Left.HT, Right.HT);
395 -------------------------
396 -- Equivalent_Elements --
397 -------------------------
399 function Equivalent_Elements (Left, Right : Cursor)
402 if Left.Node = null then
403 raise Constraint_Error with
404 "Left cursor of Equivalent_Elements equals No_Element";
407 if Right.Node = null then
408 raise Constraint_Error with
409 "Right cursor of Equivalent_Elements equals No_Element";
412 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
413 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
415 return Equivalent_Elements (Left.Node.Element, Right.Node.Element);
416 end Equivalent_Elements;
418 function Equivalent_Elements (Left : Cursor; Right : Element_Type)
421 if Left.Node = null then
422 raise Constraint_Error with
423 "Left cursor of Equivalent_Elements equals No_Element";
426 pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad");
428 return Equivalent_Elements (Left.Node.Element, Right);
429 end Equivalent_Elements;
431 function Equivalent_Elements (Left : Element_Type; Right : Cursor)
434 if Right.Node = null then
435 raise Constraint_Error with
436 "Right cursor of Equivalent_Elements equals No_Element";
441 "Right cursor of Equivalent_Elements is bad");
443 return Equivalent_Elements (Left, Right.Node.Element);
444 end Equivalent_Elements;
446 ---------------------
447 -- Equivalent_Keys --
448 ---------------------
450 function Equivalent_Keys (Key : Element_Type; Node : Node_Access)
453 return Equivalent_Elements (Key, Node.Element);
461 (Container : in out Set;
466 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
474 procedure Finalize (Container : in out Set) is
476 HT_Ops.Finalize (Container.HT);
485 Item : Element_Type) return Cursor
487 Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
494 return Cursor'(Container'Unrestricted_Access, Node);
501 function Find_Equal_Key
502 (R_HT : Hash_Table_Type;
503 L_Node : Node_Access) return Boolean
505 R_Index : constant Hash_Type :=
506 Element_Keys.Index (R_HT, L_Node.Element);
508 R_Node : Node_Access := R_HT.Buckets (R_Index);
512 if R_Node = null then
516 if L_Node.Element = R_Node.Element then
520 R_Node := Next (R_Node);
524 -------------------------
525 -- Find_Equivalent_Key --
526 -------------------------
528 function Find_Equivalent_Key
529 (R_HT : Hash_Table_Type;
530 L_Node : Node_Access) return Boolean
532 R_Index : constant Hash_Type :=
533 Element_Keys.Index (R_HT, L_Node.Element);
535 R_Node : Node_Access := R_HT.Buckets (R_Index);
539 if R_Node = null then
543 if Equivalent_Elements (L_Node.Element, R_Node.Element) then
547 R_Node := Next (R_Node);
549 end Find_Equivalent_Key;
555 function First (Container : Set) return Cursor is
556 Node : constant Node_Access := HT_Ops.First (Container.HT);
563 return Cursor'(Container'Unrestricted_Access, Node);
570 procedure Free (X : in out Node_Access) is
571 procedure Deallocate is
572 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
576 X.Next := X; -- detect mischief (in Vet)
585 function Has_Element (Position : Cursor) return Boolean is
587 pragma Assert (Vet (Position), "bad cursor in Has_Element");
588 return Position.Node /= null;
595 function Hash_Node (Node : Node_Access) return Hash_Type is
597 return Hash (Node.Element);
605 (Container : in out Set;
606 New_Item : Element_Type)
612 Insert (Container, New_Item, Position, Inserted);
615 if Container.HT.Lock > 0 then
616 raise Program_Error with
617 "attempt to tamper with elements (set is locked)";
620 Position.Node.Element := New_Item;
629 (Container : in out Set;
630 New_Item : Element_Type;
631 Position : out Cursor;
632 Inserted : out Boolean)
635 Insert (Container.HT, New_Item, Position.Node, Inserted);
636 Position.Container := Container'Unchecked_Access;
640 (Container : in out Set;
641 New_Item : Element_Type)
644 pragma Unreferenced (Position);
649 Insert (Container, New_Item, Position, Inserted);
652 raise Constraint_Error with
653 "attempt to insert element already in set";
658 (HT : in out Hash_Table_Type;
659 New_Item : Element_Type;
660 Node : out Node_Access;
661 Inserted : out Boolean)
663 function New_Node (Next : Node_Access) return Node_Access;
664 pragma Inline (New_Node);
666 procedure Local_Insert is
667 new Element_Keys.Generic_Conditional_Insert (New_Node);
673 function New_Node (Next : Node_Access) return Node_Access is
675 return new Node_Type'(New_Item, Next);
678 -- Start of processing for Insert
681 if HT_Ops.Capacity (HT) = 0 then
682 HT_Ops.Reserve_Capacity (HT, 1);
685 Local_Insert (HT, New_Item, Node, Inserted);
688 and then HT.Length > HT_Ops.Capacity (HT)
690 HT_Ops.Reserve_Capacity (HT, HT.Length);
698 procedure Intersection
699 (Target : in out Set;
702 Tgt_Node : Node_Access;
705 if Target'Address = Source'Address then
709 if Source.HT.Length = 0 then
714 if Target.HT.Busy > 0 then
715 raise Program_Error with
716 "attempt to tamper with cursors (set is busy)";
719 Tgt_Node := HT_Ops.First (Target.HT);
720 while Tgt_Node /= null loop
721 if Is_In (Source.HT, Tgt_Node) then
722 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
726 X : Node_Access := Tgt_Node;
728 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
729 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
736 function Intersection (Left, Right : Set) return Set is
737 Buckets : HT_Types.Buckets_Access;
741 if Left'Address = Right'Address then
745 Length := Count_Type'Min (Left.Length, Right.Length);
752 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
754 Buckets := HT_Ops.New_Buckets (Length => Size);
759 Iterate_Left : declare
760 procedure Process (L_Node : Node_Access);
763 new HT_Ops.Generic_Iteration (Process);
769 procedure Process (L_Node : Node_Access) is
771 if Is_In (Right.HT, L_Node) then
773 J : constant Hash_Type :=
774 Hash (L_Node.Element) mod Buckets'Length;
776 Bucket : Node_Access renames Buckets (J);
779 Bucket := new Node_Type'(L_Node.Element, Bucket);
782 Length := Length + 1;
786 -- Start of processing for Iterate_Left
792 HT_Ops.Free_Hash_Table (Buckets);
796 return (Controlled with HT => (Buckets, Length, 0, 0));
803 function Is_Empty (Container : Set) return Boolean is
805 return Container.HT.Length = 0;
812 function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
814 return Element_Keys.Find (HT, Key.Element) /= null;
821 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
822 Subset_Node : Node_Access;
825 if Subset'Address = Of_Set'Address then
829 if Subset.Length > Of_Set.Length then
833 Subset_Node := HT_Ops.First (Subset.HT);
834 while Subset_Node /= null loop
835 if not Is_In (Of_Set.HT, Subset_Node) then
838 Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
850 Process : not null access procedure (Position : Cursor))
852 procedure Process_Node (Node : Node_Access);
853 pragma Inline (Process_Node);
856 new HT_Ops.Generic_Iteration (Process_Node);
862 procedure Process_Node (Node : Node_Access) is
864 Process (Cursor'(Container'Unrestricted_Access, Node));
867 B : Natural renames Container'Unrestricted_Access.HT.Busy;
869 -- Start of processing for Iterate
875 Iterate (Container.HT);
889 function Length (Container : Set) return Count_Type is
891 return Container.HT.Length;
898 procedure Move (Target : in out Set; Source : in out Set) is
900 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
907 function Next (Node : Node_Access) return Node_Access is
912 function Next (Position : Cursor) return Cursor is
914 if Position.Node = null then
918 pragma Assert (Vet (Position), "bad cursor in Next");
921 HT : Hash_Table_Type renames Position.Container.HT;
922 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
929 return Cursor'(Position.Container, Node);
933 procedure Next (Position : in out Cursor) is
935 Position := Next (Position);
942 function Overlap (Left, Right : Set) return Boolean is
943 Left_Node : Node_Access;
946 if Right.Length = 0 then
950 if Left'Address = Right'Address then
954 Left_Node := HT_Ops.First (Left.HT);
955 while Left_Node /= null loop
956 if Is_In (Right.HT, Left_Node) then
959 Left_Node := HT_Ops.Next (Left.HT, Left_Node);
969 procedure Query_Element
971 Process : not null access procedure (Element : Element_Type))
974 if Position.Node = null then
975 raise Constraint_Error with
976 "Position cursor of Query_Element equals No_Element";
979 pragma Assert (Vet (Position), "bad cursor in Query_Element");
982 HT : Hash_Table_Type renames Position.Container.HT;
984 B : Natural renames HT.Busy;
985 L : Natural renames HT.Lock;
992 Process (Position.Node.Element);
1010 (Stream : not null access Root_Stream_Type'Class;
1011 Container : out Set)
1014 Read_Nodes (Stream, Container.HT);
1018 (Stream : not null access Root_Stream_Type'Class;
1022 raise Program_Error with "attempt to stream set cursor";
1029 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1032 Node : Node_Access := new Node_Type;
1035 Element_Type'Read (Stream, Node.Element);
1048 (Container : in out Set;
1049 New_Item : Element_Type)
1051 Node : constant Node_Access :=
1052 Element_Keys.Find (Container.HT, New_Item);
1056 raise Constraint_Error with
1057 "attempt to replace element not in set";
1060 if Container.HT.Lock > 0 then
1061 raise Program_Error with
1062 "attempt to tamper with elements (set is locked)";
1065 Node.Element := New_Item;
1068 procedure Replace_Element
1069 (Container : in out Set;
1071 New_Item : Element_Type)
1074 if Position.Node = null then
1075 raise Constraint_Error with
1076 "Position cursor equals No_Element";
1079 if Position.Container /= Container'Unrestricted_Access then
1080 raise Program_Error with
1081 "Position cursor designates wrong set";
1084 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1086 Replace_Element (Container.HT, Position.Node, New_Item);
1087 end Replace_Element;
1089 ----------------------
1090 -- Reserve_Capacity --
1091 ----------------------
1093 procedure Reserve_Capacity
1094 (Container : in out Set;
1095 Capacity : Count_Type)
1098 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1099 end Reserve_Capacity;
1105 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1110 --------------------------
1111 -- Symmetric_Difference --
1112 --------------------------
1114 procedure Symmetric_Difference
1115 (Target : in out Set;
1119 if Target'Address = Source'Address then
1124 if Target.HT.Busy > 0 then
1125 raise Program_Error with
1126 "attempt to tamper with cursors (set is busy)";
1130 N : constant Count_Type := Target.Length + Source.Length;
1132 if N > HT_Ops.Capacity (Target.HT) then
1133 HT_Ops.Reserve_Capacity (Target.HT, N);
1137 if Target.Length = 0 then
1138 Iterate_Source_When_Empty_Target : declare
1139 procedure Process (Src_Node : Node_Access);
1141 procedure Iterate is
1142 new HT_Ops.Generic_Iteration (Process);
1148 procedure Process (Src_Node : Node_Access) is
1149 E : Element_Type renames Src_Node.Element;
1150 B : Buckets_Type renames Target.HT.Buckets.all;
1151 J : constant Hash_Type := Hash (E) mod B'Length;
1152 N : Count_Type renames Target.HT.Length;
1155 B (J) := new Node_Type'(E, B (J));
1159 -- Start of processing for Iterate_Source_When_Empty_Target
1162 Iterate (Source.HT);
1163 end Iterate_Source_When_Empty_Target;
1166 Iterate_Source : declare
1167 procedure Process (Src_Node : Node_Access);
1169 procedure Iterate is
1170 new HT_Ops.Generic_Iteration (Process);
1176 procedure Process (Src_Node : Node_Access) is
1177 E : Element_Type renames Src_Node.Element;
1178 B : Buckets_Type renames Target.HT.Buckets.all;
1179 J : constant Hash_Type := Hash (E) mod B'Length;
1180 N : Count_Type renames Target.HT.Length;
1183 if B (J) = null then
1184 B (J) := new Node_Type'(E, null);
1187 elsif Equivalent_Elements (E, B (J).Element) then
1189 X : Node_Access := B (J);
1191 B (J) := B (J).Next;
1198 Prev : Node_Access := B (J);
1199 Curr : Node_Access := Prev.Next;
1202 while Curr /= null loop
1203 if Equivalent_Elements (E, Curr.Element) then
1204 Prev.Next := Curr.Next;
1214 B (J) := new Node_Type'(E, B (J));
1220 -- Start of processing for Iterate_Source
1223 Iterate (Source.HT);
1226 end Symmetric_Difference;
1228 function Symmetric_Difference (Left, Right : Set) return Set is
1229 Buckets : HT_Types.Buckets_Access;
1230 Length : Count_Type;
1233 if Left'Address = Right'Address then
1237 if Right.Length = 0 then
1241 if Left.Length = 0 then
1246 Size : constant Hash_Type :=
1247 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1249 Buckets := HT_Ops.New_Buckets (Length => Size);
1254 Iterate_Left : declare
1255 procedure Process (L_Node : Node_Access);
1257 procedure Iterate is
1258 new HT_Ops.Generic_Iteration (Process);
1264 procedure Process (L_Node : Node_Access) is
1266 if not Is_In (Right.HT, L_Node) then
1268 E : Element_Type renames L_Node.Element;
1269 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1272 Buckets (J) := new Node_Type'(E, Buckets (J));
1273 Length := Length + 1;
1278 -- Start of processing for Iterate_Left
1284 HT_Ops.Free_Hash_Table (Buckets);
1288 Iterate_Right : declare
1289 procedure Process (R_Node : Node_Access);
1291 procedure Iterate is
1292 new HT_Ops.Generic_Iteration (Process);
1298 procedure Process (R_Node : Node_Access) is
1300 if not Is_In (Left.HT, R_Node) then
1302 E : Element_Type renames R_Node.Element;
1303 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1306 Buckets (J) := new Node_Type'(E, Buckets (J));
1307 Length := Length + 1;
1312 -- Start of processing for Iterate_Right
1318 HT_Ops.Free_Hash_Table (Buckets);
1322 return (Controlled with HT => (Buckets, Length, 0, 0));
1323 end Symmetric_Difference;
1329 function To_Set (New_Item : Element_Type) return Set is
1330 HT : Hash_Table_Type;
1334 pragma Unreferenced (Node, Inserted);
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;
1378 pragma Unreferenced (Tgt_Node, Success);
1380 -- Start of processing for Process
1383 Insert (Target.HT, Src_Node.Element, Tgt_Node, Success);
1386 -- Start of processing for Union
1389 if Target'Address = Source'Address then
1393 if Target.HT.Busy > 0 then
1394 raise Program_Error with
1395 "attempt to tamper with cursors (set is busy)";
1399 N : constant Count_Type := Target.Length + Source.Length;
1401 if N > HT_Ops.Capacity (Target.HT) then
1402 HT_Ops.Reserve_Capacity (Target.HT, N);
1406 Iterate (Source.HT);
1409 function Union (Left, Right : Set) return Set is
1410 Buckets : HT_Types.Buckets_Access;
1411 Length : Count_Type;
1414 if Left'Address = Right'Address then
1418 if Right.Length = 0 then
1422 if Left.Length = 0 then
1427 Size : constant Hash_Type :=
1428 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1430 Buckets := HT_Ops.New_Buckets (Length => Size);
1433 Iterate_Left : declare
1434 procedure Process (L_Node : Node_Access);
1436 procedure Iterate is
1437 new HT_Ops.Generic_Iteration (Process);
1443 procedure Process (L_Node : Node_Access) is
1444 J : constant Hash_Type :=
1445 Hash (L_Node.Element) mod Buckets'Length;
1448 Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J));
1451 -- Start of processing for Iterate_Left
1457 HT_Ops.Free_Hash_Table (Buckets);
1461 Length := Left.Length;
1463 Iterate_Right : declare
1464 procedure Process (Src_Node : Node_Access);
1466 procedure Iterate is
1467 new HT_Ops.Generic_Iteration (Process);
1473 procedure Process (Src_Node : Node_Access) is
1474 J : constant Hash_Type :=
1475 Hash (Src_Node.Element) mod Buckets'Length;
1477 Tgt_Node : Node_Access := Buckets (J);
1480 while Tgt_Node /= null loop
1481 if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1485 Tgt_Node := Next (Tgt_Node);
1488 Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J));
1489 Length := Length + 1;
1492 -- Start of processing for Iterate_Right
1498 HT_Ops.Free_Hash_Table (Buckets);
1502 return (Controlled with HT => (Buckets, Length, 0, 0));
1509 function Vet (Position : Cursor) return Boolean is
1511 if Position.Node = null then
1512 return Position.Container = null;
1515 if Position.Container = null then
1519 if Position.Node.Next = Position.Node then
1524 HT : Hash_Table_Type renames Position.Container.HT;
1528 if HT.Length = 0 then
1532 if HT.Buckets = null
1533 or else HT.Buckets'Length = 0
1538 X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element));
1540 for J in 1 .. HT.Length loop
1541 if X = Position.Node then
1549 if X = X.Next then -- to prevent unnecessary looping
1565 (Stream : not null access Root_Stream_Type'Class;
1569 Write_Nodes (Stream, Container.HT);
1573 (Stream : not null access Root_Stream_Type'Class;
1577 raise Program_Error with "attempt to stream set cursor";
1584 procedure Write_Node
1585 (Stream : not null access Root_Stream_Type'Class;
1589 Element_Type'Write (Stream, Node.Element);
1592 package body Generic_Keys is
1594 -----------------------
1595 -- Local Subprograms --
1596 -----------------------
1598 function Equivalent_Key_Node
1600 Node : Node_Access) return Boolean;
1601 pragma Inline (Equivalent_Key_Node);
1603 --------------------------
1604 -- Local Instantiations --
1605 --------------------------
1608 new Hash_Tables.Generic_Keys
1609 (HT_Types => HT_Types,
1611 Set_Next => Set_Next,
1612 Key_Type => Key_Type,
1614 Equivalent_Keys => Equivalent_Key_Node);
1622 Key : Key_Type) return Boolean
1625 return Find (Container, Key) /= No_Element;
1633 (Container : in out Set;
1639 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1642 raise Constraint_Error with "attempt to delete key not in set";
1654 Key : Key_Type) return Element_Type
1656 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1660 raise Constraint_Error with "key not in map";
1663 return Node.Element;
1666 -------------------------
1667 -- Equivalent_Key_Node --
1668 -------------------------
1670 function Equivalent_Key_Node
1672 Node : Node_Access) return Boolean
1675 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1676 end Equivalent_Key_Node;
1683 (Container : in out Set;
1688 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1698 Key : Key_Type) return Cursor
1700 Node : constant Node_Access :=
1701 Key_Keys.Find (Container.HT, Key);
1708 return Cursor'(Container'Unrestricted_Access, Node);
1715 function Key (Position : Cursor) return Key_Type is
1717 if Position.Node = null then
1718 raise Constraint_Error with
1719 "Position cursor equals No_Element";
1722 pragma Assert (Vet (Position), "bad cursor in function Key");
1724 return Key (Position.Node.Element);
1732 (Container : in out Set;
1734 New_Item : Element_Type)
1736 Node : constant Node_Access :=
1737 Key_Keys.Find (Container.HT, Key);
1741 raise Constraint_Error with
1742 "attempt to replace key not in set";
1745 Replace_Element (Container.HT, Node, New_Item);
1748 -----------------------------------
1749 -- Update_Element_Preserving_Key --
1750 -----------------------------------
1752 procedure Update_Element_Preserving_Key
1753 (Container : in out Set;
1755 Process : not null access
1756 procedure (Element : in out Element_Type))
1758 HT : Hash_Table_Type renames Container.HT;
1762 if Position.Node = null then
1763 raise Constraint_Error with
1764 "Position cursor equals No_Element";
1767 if Position.Container /= Container'Unrestricted_Access then
1768 raise Program_Error with
1769 "Position cursor designates wrong set";
1772 if HT.Buckets = null
1773 or else HT.Buckets'Length = 0
1774 or else HT.Length = 0
1775 or else Position.Node.Next = Position.Node
1777 raise Program_Error with "Position cursor is bad (set is empty)";
1782 "bad cursor in Update_Element_Preserving_Key");
1784 Indx := HT_Ops.Index (HT, Position.Node);
1787 E : Element_Type renames Position.Node.Element;
1788 K : constant Key_Type := Key (E);
1790 B : Natural renames HT.Busy;
1791 L : Natural renames HT.Lock;
1809 if Equivalent_Keys (K, Key (E)) then
1810 pragma Assert (Hash (K) = Hash (E));
1815 if HT.Buckets (Indx) = Position.Node then
1816 HT.Buckets (Indx) := Position.Node.Next;
1820 Prev : Node_Access := HT.Buckets (Indx);
1823 while Prev.Next /= Position.Node loop
1827 raise Program_Error with
1828 "Position cursor is bad (node not found)";
1832 Prev.Next := Position.Node.Next;
1836 HT.Length := HT.Length - 1;
1839 X : Node_Access := Position.Node;
1845 raise Program_Error with "key was modified";
1846 end Update_Element_Preserving_Key;
1850 end Ada.Containers.Hashed_Sets;