1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_HASHED_SETS --
9 -- Copyright (C) 2004-2012, 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.Indefinite_Hashed_Sets is
44 type Iterator is new Limited_Controlled and
45 Set_Iterator_Interfaces.Forward_Iterator with
47 Container : Set_Access;
50 overriding procedure Finalize (Object : in out Iterator);
52 overriding function First (Object : Iterator) return Cursor;
54 overriding function Next
56 Position : Cursor) return Cursor;
58 -----------------------
59 -- Local Subprograms --
60 -----------------------
62 procedure Assign (Node : Node_Access; Item : Element_Type);
63 pragma Inline (Assign);
65 function Copy_Node (Source : Node_Access) return Node_Access;
66 pragma Inline (Copy_Node);
68 function Equivalent_Keys
70 Node : Node_Access) return Boolean;
71 pragma Inline (Equivalent_Keys);
73 function Find_Equal_Key
74 (R_HT : Hash_Table_Type;
75 L_Node : Node_Access) return Boolean;
77 function Find_Equivalent_Key
78 (R_HT : Hash_Table_Type;
79 L_Node : Node_Access) return Boolean;
81 procedure Free (X : in out Node_Access);
83 function Hash_Node (Node : Node_Access) return Hash_Type;
84 pragma Inline (Hash_Node);
87 (HT : in out Hash_Table_Type;
88 New_Item : Element_Type;
89 Node : out Node_Access;
90 Inserted : out Boolean);
92 function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean;
93 pragma Inline (Is_In);
95 function Next (Node : Node_Access) return Node_Access;
98 function Read_Node (Stream : not null access Root_Stream_Type'Class)
100 pragma Inline (Read_Node);
102 procedure Set_Next (Node : Node_Access; Next : Node_Access);
103 pragma Inline (Set_Next);
105 function Vet (Position : Cursor) return Boolean;
108 (Stream : not null access Root_Stream_Type'Class;
110 pragma Inline (Write_Node);
112 --------------------------
113 -- Local Instantiations --
114 --------------------------
116 procedure Free_Element is
117 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
119 package HT_Ops is new Hash_Tables.Generic_Operations
120 (HT_Types => HT_Types,
121 Hash_Node => Hash_Node,
123 Set_Next => Set_Next,
124 Copy_Node => Copy_Node,
127 package Element_Keys is new Hash_Tables.Generic_Keys
128 (HT_Types => HT_Types,
130 Set_Next => Set_Next,
131 Key_Type => Element_Type,
133 Equivalent_Keys => Equivalent_Keys);
136 new HT_Ops.Generic_Equal (Find_Equal_Key);
138 function Is_Equivalent is
139 new HT_Ops.Generic_Equal (Find_Equivalent_Key);
141 procedure Read_Nodes is
142 new HT_Ops.Generic_Read (Read_Node);
144 procedure Replace_Element is
145 new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
147 procedure Write_Nodes is
148 new HT_Ops.Generic_Write (Write_Node);
154 function "=" (Left, Right : Set) return Boolean is
156 return Is_Equal (Left.HT, Right.HT);
163 procedure Adjust (Container : in out Set) is
165 HT_Ops.Adjust (Container.HT);
168 procedure Adjust (Control : in out Reference_Control_Type) is
170 if Control.Container /= null then
172 HT : Hash_Table_Type renames Control.Container.all.HT;
173 B : Natural renames HT.Busy;
174 L : Natural renames HT.Lock;
186 procedure Assign (Node : Node_Access; Item : Element_Type) is
187 X : Element_Access := Node.Element;
189 Node.Element := new Element_Type'(Item);
193 procedure Assign (Target : in out Set; Source : Set) is
195 if Target'Address = Source'Address then
200 Target.Union (Source);
207 function Capacity (Container : Set) return Count_Type is
209 return HT_Ops.Capacity (Container.HT);
216 procedure Clear (Container : in out Set) is
218 HT_Ops.Clear (Container.HT);
221 ------------------------
222 -- Constant_Reference --
223 ------------------------
225 function Constant_Reference
226 (Container : aliased Set;
227 Position : Cursor) return Constant_Reference_Type
230 if Position.Container = null then
231 raise Constraint_Error with "Position cursor has no element";
234 if Position.Container /= Container'Unrestricted_Access then
235 raise Program_Error with
236 "Position cursor designates wrong container";
239 if Position.Node.Element = null then
240 raise Program_Error with "Node has no element";
243 pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
246 HT : Hash_Table_Type renames Position.Container.all.HT;
247 B : Natural renames HT.Busy;
248 L : Natural renames HT.Lock;
250 return R : constant Constant_Reference_Type :=
251 (Element => Position.Node.Element.all'Access,
253 (Controlled with Container'Unrestricted_Access))
259 end Constant_Reference;
265 function Contains (Container : Set; Item : Element_Type) return Boolean is
267 return Find (Container, Item) /= No_Element;
276 Capacity : Count_Type := 0) return Set
284 elsif Capacity >= Source.Length then
289 with "Requested capacity is less than Source length";
292 return Target : Set do
293 Target.Reserve_Capacity (C);
294 Target.Assign (Source);
302 function Copy_Node (Source : Node_Access) return Node_Access is
303 E : Element_Access := new Element_Type'(Source.Element.all);
305 return new Node_Type'(Element => E, Next => null);
317 (Container : in out Set;
323 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
326 raise Constraint_Error with "attempt to delete element not in set";
333 (Container : in out Set;
334 Position : in out Cursor)
337 if Position.Node = null then
338 raise Constraint_Error with "Position cursor equals No_Element";
341 if Position.Node.Element = null then
342 raise Program_Error with "Position cursor is bad";
345 if Position.Container /= Container'Unrestricted_Access then
346 raise Program_Error with "Position cursor designates wrong set";
349 if Container.HT.Busy > 0 then
350 raise Program_Error with
351 "attempt to tamper with cursors (set is busy)";
354 pragma Assert (Vet (Position), "Position cursor is bad");
356 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
358 Free (Position.Node);
359 Position.Container := null;
367 (Target : in out Set;
370 Tgt_Node : Node_Access;
373 if Target'Address = Source'Address then
378 if Source.HT.Length = 0 then
382 if Target.HT.Busy > 0 then
383 raise Program_Error with
384 "attempt to tamper with cursors (set is busy)";
387 if Source.HT.Length < Target.HT.Length then
389 Src_Node : Node_Access;
392 Src_Node := HT_Ops.First (Source.HT);
393 while Src_Node /= null loop
394 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
396 if Tgt_Node /= null then
397 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
401 Src_Node := HT_Ops.Next (Source.HT, Src_Node);
406 Tgt_Node := HT_Ops.First (Target.HT);
407 while Tgt_Node /= null loop
408 if Is_In (Source.HT, Tgt_Node) then
410 X : Node_Access := Tgt_Node;
412 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
413 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
418 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
424 function Difference (Left, Right : Set) return Set is
425 Buckets : HT_Types.Buckets_Access;
429 if Left'Address = Right'Address then
433 if Left.Length = 0 then
437 if Right.Length = 0 then
442 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
444 Buckets := HT_Ops.New_Buckets (Length => Size);
449 Iterate_Left : declare
450 procedure Process (L_Node : Node_Access);
453 new HT_Ops.Generic_Iteration (Process);
459 procedure Process (L_Node : Node_Access) is
461 if not Is_In (Right.HT, L_Node) then
463 Src : Element_Type renames L_Node.Element.all;
464 Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
465 Bucket : Node_Access renames Buckets (Indx);
466 Tgt : Element_Access := new Element_Type'(Src);
468 Bucket := new Node_Type'(Tgt, Bucket);
475 Length := Length + 1;
479 -- Start of processing for Iterate_Left
485 HT_Ops.Free_Hash_Table (Buckets);
489 return (Controlled with HT => (Buckets, Length, 0, 0));
496 function Element (Position : Cursor) return Element_Type is
498 if Position.Node = null then
499 raise Constraint_Error with "Position cursor of equals No_Element";
502 if Position.Node.Element = null then -- handle dangling reference
503 raise Program_Error with "Position cursor is bad";
506 pragma Assert (Vet (Position), "bad cursor in function Element");
508 return Position.Node.Element.all;
511 ---------------------
512 -- Equivalent_Sets --
513 ---------------------
515 function Equivalent_Sets (Left, Right : Set) return Boolean is
517 return Is_Equivalent (Left.HT, Right.HT);
520 -------------------------
521 -- Equivalent_Elements --
522 -------------------------
524 function Equivalent_Elements (Left, Right : Cursor) return Boolean is
526 if Left.Node = null then
527 raise Constraint_Error with
528 "Left cursor of Equivalent_Elements equals No_Element";
531 if Right.Node = null then
532 raise Constraint_Error with
533 "Right cursor of Equivalent_Elements equals No_Element";
536 if Left.Node.Element = null then
537 raise Program_Error with
538 "Left cursor of Equivalent_Elements is bad";
541 if Right.Node.Element = null then
542 raise Program_Error with
543 "Right cursor of Equivalent_Elements is bad";
546 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
547 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
549 return Equivalent_Elements
550 (Left.Node.Element.all,
551 Right.Node.Element.all);
552 end Equivalent_Elements;
554 function Equivalent_Elements
556 Right : Element_Type) return Boolean
559 if Left.Node = null then
560 raise Constraint_Error with
561 "Left cursor of Equivalent_Elements equals No_Element";
564 if Left.Node.Element = null then
565 raise Program_Error with
566 "Left cursor of Equivalent_Elements is bad";
569 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
571 return Equivalent_Elements (Left.Node.Element.all, Right);
572 end Equivalent_Elements;
574 function Equivalent_Elements
575 (Left : Element_Type;
576 Right : Cursor) return Boolean
579 if Right.Node = null then
580 raise Constraint_Error with
581 "Right cursor of Equivalent_Elements equals No_Element";
584 if Right.Node.Element = null then
585 raise Program_Error with
586 "Right cursor of Equivalent_Elements is bad";
589 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
591 return Equivalent_Elements (Left, Right.Node.Element.all);
592 end Equivalent_Elements;
594 ---------------------
595 -- Equivalent_Keys --
596 ---------------------
598 function Equivalent_Keys
600 Node : Node_Access) return Boolean
603 return Equivalent_Elements (Key, Node.Element.all);
611 (Container : in out Set;
616 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
624 procedure Finalize (Container : in out Set) is
626 HT_Ops.Finalize (Container.HT);
629 procedure Finalize (Object : in out Iterator) is
631 if Object.Container /= null then
633 B : Natural renames Object.Container.all.HT.Busy;
640 procedure Finalize (Control : in out Reference_Control_Type) is
642 if Control.Container /= null then
644 HT : Hash_Table_Type renames Control.Container.all.HT;
645 B : Natural renames HT.Busy;
646 L : Natural renames HT.Lock;
652 Control.Container := null;
662 Item : Element_Type) return Cursor
664 Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
666 return (if Node = null then No_Element
667 else Cursor'(Container'Unrestricted_Access, Node));
674 function Find_Equal_Key
675 (R_HT : Hash_Table_Type;
676 L_Node : Node_Access) return Boolean
678 R_Index : constant Hash_Type :=
679 Element_Keys.Index (R_HT, L_Node.Element.all);
681 R_Node : Node_Access := R_HT.Buckets (R_Index);
685 if R_Node = null then
689 if L_Node.Element.all = R_Node.Element.all then
693 R_Node := Next (R_Node);
697 -------------------------
698 -- Find_Equivalent_Key --
699 -------------------------
701 function Find_Equivalent_Key
702 (R_HT : Hash_Table_Type;
703 L_Node : Node_Access) return Boolean
705 R_Index : constant Hash_Type :=
706 Element_Keys.Index (R_HT, L_Node.Element.all);
708 R_Node : Node_Access := R_HT.Buckets (R_Index);
712 if R_Node = null then
716 if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
720 R_Node := Next (R_Node);
722 end Find_Equivalent_Key;
728 function First (Container : Set) return Cursor is
729 Node : constant Node_Access := HT_Ops.First (Container.HT);
731 return (if Node = null then No_Element
732 else Cursor'(Container'Unrestricted_Access, Node));
735 function First (Object : Iterator) return Cursor is
737 return Object.Container.First;
744 procedure Free (X : in out Node_Access) is
745 procedure Deallocate is
746 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
753 X.Next := X; -- detect mischief (in Vet)
756 Free_Element (X.Element);
771 function Has_Element (Position : Cursor) return Boolean is
773 pragma Assert (Vet (Position), "bad cursor in Has_Element");
774 return Position.Node /= null;
781 function Hash_Node (Node : Node_Access) return Hash_Type is
783 return Hash (Node.Element.all);
791 (Container : in out Set;
792 New_Item : Element_Type)
800 Insert (Container, New_Item, Position, Inserted);
803 if Container.HT.Lock > 0 then
804 raise Program_Error with
805 "attempt to tamper with elements (set is locked)";
808 X := Position.Node.Element;
810 Position.Node.Element := new Element_Type'(New_Item);
821 (Container : in out Set;
822 New_Item : Element_Type;
823 Position : out Cursor;
824 Inserted : out Boolean)
827 Insert (Container.HT, New_Item, Position.Node, Inserted);
828 Position.Container := Container'Unchecked_Access;
832 (Container : in out Set;
833 New_Item : Element_Type)
836 pragma Unreferenced (Position);
841 Insert (Container, New_Item, Position, Inserted);
844 raise Constraint_Error with
845 "attempt to insert element already in set";
850 (HT : in out Hash_Table_Type;
851 New_Item : Element_Type;
852 Node : out Node_Access;
853 Inserted : out Boolean)
855 function New_Node (Next : Node_Access) return Node_Access;
856 pragma Inline (New_Node);
858 procedure Local_Insert is
859 new Element_Keys.Generic_Conditional_Insert (New_Node);
865 function New_Node (Next : Node_Access) return Node_Access is
866 Element : Element_Access := new Element_Type'(New_Item);
868 return new Node_Type'(Element, Next);
871 Free_Element (Element);
875 -- Start of processing for Insert
878 if HT_Ops.Capacity (HT) = 0 then
879 HT_Ops.Reserve_Capacity (HT, 1);
882 Local_Insert (HT, New_Item, Node, Inserted);
885 and then HT.Length > HT_Ops.Capacity (HT)
887 HT_Ops.Reserve_Capacity (HT, HT.Length);
895 procedure Intersection
896 (Target : in out Set;
899 Tgt_Node : Node_Access;
902 if Target'Address = Source'Address then
906 if Source.Length = 0 then
911 if Target.HT.Busy > 0 then
912 raise Program_Error with
913 "attempt to tamper with cursors (set is busy)";
916 Tgt_Node := HT_Ops.First (Target.HT);
917 while Tgt_Node /= null loop
918 if Is_In (Source.HT, Tgt_Node) then
919 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
923 X : Node_Access := Tgt_Node;
925 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
926 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
933 function Intersection (Left, Right : Set) return Set is
934 Buckets : HT_Types.Buckets_Access;
938 if Left'Address = Right'Address then
942 Length := Count_Type'Min (Left.Length, Right.Length);
949 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
951 Buckets := HT_Ops.New_Buckets (Length => Size);
956 Iterate_Left : declare
957 procedure Process (L_Node : Node_Access);
960 new HT_Ops.Generic_Iteration (Process);
966 procedure Process (L_Node : Node_Access) is
968 if Is_In (Right.HT, L_Node) then
970 Src : Element_Type renames L_Node.Element.all;
972 Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
974 Bucket : Node_Access renames Buckets (Indx);
976 Tgt : Element_Access := new Element_Type'(Src);
979 Bucket := new Node_Type'(Tgt, Bucket);
986 Length := Length + 1;
990 -- Start of processing for Iterate_Left
996 HT_Ops.Free_Hash_Table (Buckets);
1000 return (Controlled with HT => (Buckets, Length, 0, 0));
1007 function Is_Empty (Container : Set) return Boolean is
1009 return Container.HT.Length = 0;
1016 function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
1018 return Element_Keys.Find (HT, Key.Element.all) /= null;
1027 Of_Set : Set) return Boolean
1029 Subset_Node : Node_Access;
1032 if Subset'Address = Of_Set'Address then
1036 if Subset.Length > Of_Set.Length then
1040 Subset_Node := HT_Ops.First (Subset.HT);
1041 while Subset_Node /= null loop
1042 if not Is_In (Of_Set.HT, Subset_Node) then
1046 Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
1058 Process : not null access procedure (Position : Cursor))
1060 procedure Process_Node (Node : Node_Access);
1061 pragma Inline (Process_Node);
1063 procedure Iterate is
1064 new HT_Ops.Generic_Iteration (Process_Node);
1070 procedure Process_Node (Node : Node_Access) is
1072 Process (Cursor'(Container'Unrestricted_Access, Node));
1075 B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1077 -- Start of processing for Iterate
1083 Iterate (Container.HT);
1093 function Iterate (Container : Set)
1094 return Set_Iterator_Interfaces.Forward_Iterator'Class
1096 B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1098 return It : constant Iterator :=
1099 Iterator'(Limited_Controlled with
1100 Container => Container'Unrestricted_Access)
1110 function Length (Container : Set) return Count_Type is
1112 return Container.HT.Length;
1119 procedure Move (Target : in out Set; Source : in out Set) is
1121 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
1128 function Next (Node : Node_Access) return Node_Access is
1133 function Next (Position : Cursor) return Cursor is
1135 if Position.Node = null then
1139 if Position.Node.Element = null then
1140 raise Program_Error with "bad cursor in Next";
1143 pragma Assert (Vet (Position), "bad cursor in Next");
1146 HT : Hash_Table_Type renames Position.Container.HT;
1147 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
1149 return (if Node = null then No_Element
1150 else Cursor'(Position.Container, Node));
1154 procedure Next (Position : in out Cursor) is
1156 Position := Next (Position);
1161 Position : Cursor) return Cursor
1164 if Position.Container = null then
1168 if Position.Container /= Object.Container then
1169 raise Program_Error with
1170 "Position cursor of Next designates wrong set";
1173 return Next (Position);
1180 function Overlap (Left, Right : Set) return Boolean is
1181 Left_Node : Node_Access;
1184 if Right.Length = 0 then
1188 if Left'Address = Right'Address then
1192 Left_Node := HT_Ops.First (Left.HT);
1193 while Left_Node /= null loop
1194 if Is_In (Right.HT, Left_Node) then
1198 Left_Node := HT_Ops.Next (Left.HT, Left_Node);
1208 procedure Query_Element
1210 Process : not null access procedure (Element : Element_Type))
1213 if Position.Node = null then
1214 raise Constraint_Error with
1215 "Position cursor of Query_Element equals No_Element";
1218 if Position.Node.Element = null then
1219 raise Program_Error with "bad cursor in Query_Element";
1222 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1225 HT : Hash_Table_Type renames
1226 Position.Container'Unrestricted_Access.all.HT;
1228 B : Natural renames HT.Busy;
1229 L : Natural renames HT.Lock;
1236 Process (Position.Node.Element.all);
1254 (Stream : not null access Root_Stream_Type'Class;
1255 Container : out Set)
1258 Read_Nodes (Stream, Container.HT);
1262 (Stream : not null access Root_Stream_Type'Class;
1266 raise Program_Error with "attempt to stream set cursor";
1270 (Stream : not null access Root_Stream_Type'Class;
1271 Item : out Constant_Reference_Type)
1274 raise Program_Error with "attempt to stream reference";
1282 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1284 X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
1286 return new Node_Type'(X, null);
1298 (Container : in out Set;
1299 New_Item : Element_Type)
1301 Node : constant Node_Access :=
1302 Element_Keys.Find (Container.HT, New_Item);
1305 pragma Warnings (Off, X);
1309 raise Constraint_Error with
1310 "attempt to replace element not in set";
1313 if Container.HT.Lock > 0 then
1314 raise Program_Error with
1315 "attempt to tamper with elements (set is locked)";
1320 Node.Element := new Element_Type'(New_Item);
1325 ---------------------
1326 -- Replace_Element --
1327 ---------------------
1329 procedure Replace_Element
1330 (Container : in out Set;
1332 New_Item : Element_Type)
1335 if Position.Node = null then
1336 raise Constraint_Error with "Position cursor equals No_Element";
1339 if Position.Node.Element = null then
1340 raise Program_Error with "bad cursor in Replace_Element";
1343 if Position.Container /= Container'Unrestricted_Access then
1344 raise Program_Error with
1345 "Position cursor designates wrong set";
1348 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1350 Replace_Element (Container.HT, Position.Node, New_Item);
1351 end Replace_Element;
1353 ----------------------
1354 -- Reserve_Capacity --
1355 ----------------------
1357 procedure Reserve_Capacity
1358 (Container : in out Set;
1359 Capacity : Count_Type)
1362 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1363 end Reserve_Capacity;
1369 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1374 --------------------------
1375 -- Symmetric_Difference --
1376 --------------------------
1378 procedure Symmetric_Difference
1379 (Target : in out Set;
1383 if Target'Address = Source'Address then
1388 if Target.HT.Busy > 0 then
1389 raise Program_Error with
1390 "attempt to tamper with cursors (set is busy)";
1394 N : constant Count_Type := Target.Length + Source.Length;
1396 if N > HT_Ops.Capacity (Target.HT) then
1397 HT_Ops.Reserve_Capacity (Target.HT, N);
1401 if Target.Length = 0 then
1402 Iterate_Source_When_Empty_Target : declare
1403 procedure Process (Src_Node : Node_Access);
1405 procedure Iterate is new HT_Ops.Generic_Iteration (Process);
1411 procedure Process (Src_Node : Node_Access) is
1412 E : Element_Type renames Src_Node.Element.all;
1413 B : Buckets_Type renames Target.HT.Buckets.all;
1414 J : constant Hash_Type := Hash (E) mod B'Length;
1415 N : Count_Type renames Target.HT.Length;
1419 X : Element_Access := new Element_Type'(E);
1421 B (J) := new Node_Type'(X, B (J));
1431 -- Start of processing for Iterate_Source_When_Empty_Target
1434 Iterate (Source.HT);
1435 end Iterate_Source_When_Empty_Target;
1438 Iterate_Source : declare
1439 procedure Process (Src_Node : Node_Access);
1441 procedure Iterate is
1442 new HT_Ops.Generic_Iteration (Process);
1448 procedure Process (Src_Node : Node_Access) is
1449 E : Element_Type renames Src_Node.Element.all;
1450 B : Buckets_Type renames Target.HT.Buckets.all;
1451 J : constant Hash_Type := Hash (E) mod B'Length;
1452 N : Count_Type renames Target.HT.Length;
1455 if B (J) = null then
1457 X : Element_Access := new Element_Type'(E);
1459 B (J) := new Node_Type'(X, null);
1468 elsif Equivalent_Elements (E, B (J).Element.all) then
1470 X : Node_Access := B (J);
1472 B (J) := B (J).Next;
1479 Prev : Node_Access := B (J);
1480 Curr : Node_Access := Prev.Next;
1483 while Curr /= null loop
1484 if Equivalent_Elements (E, Curr.Element.all) then
1485 Prev.Next := Curr.Next;
1496 X : Element_Access := new Element_Type'(E);
1498 B (J) := new Node_Type'(X, B (J));
1510 -- Start of processing for Iterate_Source
1513 Iterate (Source.HT);
1516 end Symmetric_Difference;
1518 function Symmetric_Difference (Left, Right : Set) return Set is
1519 Buckets : HT_Types.Buckets_Access;
1520 Length : Count_Type;
1523 if Left'Address = Right'Address then
1527 if Right.Length = 0 then
1531 if Left.Length = 0 then
1536 Size : constant Hash_Type :=
1537 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1539 Buckets := HT_Ops.New_Buckets (Length => Size);
1544 Iterate_Left : declare
1545 procedure Process (L_Node : Node_Access);
1547 procedure Iterate is
1548 new HT_Ops.Generic_Iteration (Process);
1554 procedure Process (L_Node : Node_Access) is
1556 if not Is_In (Right.HT, L_Node) then
1558 E : Element_Type renames L_Node.Element.all;
1559 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1563 X : Element_Access := new Element_Type'(E);
1565 Buckets (J) := new Node_Type'(X, Buckets (J));
1572 Length := Length + 1;
1577 -- Start of processing for Iterate_Left
1583 HT_Ops.Free_Hash_Table (Buckets);
1587 Iterate_Right : declare
1588 procedure Process (R_Node : Node_Access);
1590 procedure Iterate is
1591 new HT_Ops.Generic_Iteration (Process);
1597 procedure Process (R_Node : Node_Access) is
1599 if not Is_In (Left.HT, R_Node) then
1601 E : Element_Type renames R_Node.Element.all;
1602 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1606 X : Element_Access := new Element_Type'(E);
1608 Buckets (J) := new Node_Type'(X, Buckets (J));
1615 Length := Length + 1;
1620 -- Start of processing for Iterate_Right
1626 HT_Ops.Free_Hash_Table (Buckets);
1630 return (Controlled with HT => (Buckets, Length, 0, 0));
1631 end Symmetric_Difference;
1637 function To_Set (New_Item : Element_Type) return Set is
1638 HT : Hash_Table_Type;
1641 pragma Unreferenced (Node, Inserted);
1643 Insert (HT, New_Item, Node, Inserted);
1644 return Set'(Controlled with HT);
1652 (Target : in out Set;
1655 procedure Process (Src_Node : Node_Access);
1657 procedure Iterate is
1658 new HT_Ops.Generic_Iteration (Process);
1664 procedure Process (Src_Node : Node_Access) is
1665 Src : Element_Type renames Src_Node.Element.all;
1667 function New_Node (Next : Node_Access) return Node_Access;
1668 pragma Inline (New_Node);
1671 new Element_Keys.Generic_Conditional_Insert (New_Node);
1677 function New_Node (Next : Node_Access) return Node_Access is
1678 Tgt : Element_Access := new Element_Type'(Src);
1680 return new Node_Type'(Tgt, Next);
1687 Tgt_Node : Node_Access;
1689 pragma Unreferenced (Tgt_Node, Success);
1691 -- Start of processing for Process
1694 Insert (Target.HT, Src, Tgt_Node, Success);
1697 -- Start of processing for Union
1700 if Target'Address = Source'Address then
1704 if Target.HT.Busy > 0 then
1705 raise Program_Error with
1706 "attempt to tamper with cursors (set is busy)";
1710 N : constant Count_Type := Target.Length + Source.Length;
1712 if N > HT_Ops.Capacity (Target.HT) then
1713 HT_Ops.Reserve_Capacity (Target.HT, N);
1717 Iterate (Source.HT);
1720 function Union (Left, Right : Set) return Set is
1721 Buckets : HT_Types.Buckets_Access;
1722 Length : Count_Type;
1725 if Left'Address = Right'Address then
1729 if Right.Length = 0 then
1733 if Left.Length = 0 then
1738 Size : constant Hash_Type :=
1739 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1741 Buckets := HT_Ops.New_Buckets (Length => Size);
1744 Iterate_Left : declare
1745 procedure Process (L_Node : Node_Access);
1747 procedure Iterate is
1748 new HT_Ops.Generic_Iteration (Process);
1754 procedure Process (L_Node : Node_Access) is
1755 Src : Element_Type renames L_Node.Element.all;
1756 J : constant Hash_Type := Hash (Src) mod Buckets'Length;
1757 Bucket : Node_Access renames Buckets (J);
1758 Tgt : Element_Access := new Element_Type'(Src);
1760 Bucket := new Node_Type'(Tgt, Bucket);
1767 -- Start of processing for Process
1773 HT_Ops.Free_Hash_Table (Buckets);
1777 Length := Left.Length;
1779 Iterate_Right : declare
1780 procedure Process (Src_Node : Node_Access);
1782 procedure Iterate is
1783 new HT_Ops.Generic_Iteration (Process);
1789 procedure Process (Src_Node : Node_Access) is
1790 Src : Element_Type renames Src_Node.Element.all;
1791 Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
1793 Tgt_Node : Node_Access := Buckets (Idx);
1796 while Tgt_Node /= null loop
1797 if Equivalent_Elements (Src, Tgt_Node.Element.all) then
1800 Tgt_Node := Next (Tgt_Node);
1804 Tgt : Element_Access := new Element_Type'(Src);
1806 Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx));
1813 Length := Length + 1;
1816 -- Start of processing for Iterate_Right
1822 HT_Ops.Free_Hash_Table (Buckets);
1826 return (Controlled with HT => (Buckets, Length, 0, 0));
1833 function Vet (Position : Cursor) return Boolean is
1835 if Position.Node = null then
1836 return Position.Container = null;
1839 if Position.Container = null then
1843 if Position.Node.Next = Position.Node then
1847 if Position.Node.Element = null then
1852 HT : Hash_Table_Type renames Position.Container.HT;
1856 if HT.Length = 0 then
1860 if HT.Buckets = null
1861 or else HT.Buckets'Length = 0
1866 X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
1868 for J in 1 .. HT.Length loop
1869 if X = Position.Node then
1877 if X = X.Next then -- to prevent unnecessary looping
1893 (Stream : not null access Root_Stream_Type'Class;
1897 Write_Nodes (Stream, Container.HT);
1901 (Stream : not null access Root_Stream_Type'Class;
1905 raise Program_Error with "attempt to stream set cursor";
1909 (Stream : not null access Root_Stream_Type'Class;
1910 Item : Constant_Reference_Type)
1913 raise Program_Error with "attempt to stream reference";
1920 procedure Write_Node
1921 (Stream : not null access Root_Stream_Type'Class;
1925 Element_Type'Output (Stream, Node.Element.all);
1928 package body Generic_Keys is
1930 -----------------------
1931 -- Local Subprograms --
1932 -----------------------
1934 function Equivalent_Key_Node
1936 Node : Node_Access) return Boolean;
1937 pragma Inline (Equivalent_Key_Node);
1939 --------------------------
1940 -- Local Instantiations --
1941 --------------------------
1944 new Hash_Tables.Generic_Keys
1945 (HT_Types => HT_Types,
1947 Set_Next => Set_Next,
1948 Key_Type => Key_Type,
1950 Equivalent_Keys => Equivalent_Key_Node);
1952 ------------------------
1953 -- Constant_Reference --
1954 ------------------------
1956 function Constant_Reference
1957 (Container : aliased Set;
1958 Key : Key_Type) return Constant_Reference_Type
1960 Node : constant Node_Access :=
1961 Key_Keys.Find (Container.HT, Key);
1965 raise Constraint_Error with "Key not in set";
1968 if Node.Element = null then
1969 raise Program_Error with "Node has no element";
1973 HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
1974 B : Natural renames HT.Busy;
1975 L : Natural renames HT.Lock;
1977 return R : constant Constant_Reference_Type :=
1978 (Element => Node.Element.all'Access,
1980 (Controlled with Container'Unrestricted_Access))
1986 end Constant_Reference;
1994 Key : Key_Type) return Boolean
1997 return Find (Container, Key) /= No_Element;
2005 (Container : in out Set;
2011 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2014 raise Constraint_Error with "key not in map"; -- ??? "set"
2026 Key : Key_Type) return Element_Type
2028 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2032 raise Constraint_Error with "key not in map"; -- ??? "set"
2035 return Node.Element.all;
2038 -------------------------
2039 -- Equivalent_Key_Node --
2040 -------------------------
2042 function Equivalent_Key_Node
2044 Node : Node_Access) return Boolean is
2046 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
2047 end Equivalent_Key_Node;
2054 (Container : in out Set;
2059 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2069 Key : Key_Type) return Cursor
2071 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2073 return (if Node = null then No_Element
2074 else Cursor'(Container'Unrestricted_Access, Node));
2081 function Key (Position : Cursor) return Key_Type is
2083 if Position.Node = null then
2084 raise Constraint_Error with
2085 "Position cursor equals No_Element";
2088 if Position.Node.Element = null then
2089 raise Program_Error with "Position cursor is bad";
2092 pragma Assert (Vet (Position), "bad cursor in function Key");
2094 return Key (Position.Node.Element.all);
2102 (Stream : not null access Root_Stream_Type'Class;
2103 Item : out Reference_Type)
2106 raise Program_Error with "attempt to stream reference";
2109 ------------------------------
2110 -- Reference_Preserving_Key --
2111 ------------------------------
2113 function Reference_Preserving_Key
2114 (Container : aliased in out Set;
2115 Position : Cursor) return Reference_Type
2118 if Position.Container = null then
2119 raise Constraint_Error with "Position cursor has no element";
2122 if Position.Container /= Container'Unrestricted_Access then
2123 raise Program_Error with
2124 "Position cursor designates wrong container";
2127 if Position.Node.Element = null then
2128 raise Program_Error with "Node has no element";
2133 "bad cursor in function Reference_Preserving_Key");
2135 -- Some form of finalization will be required in order to actually
2136 -- check that the key-part of the element designated by Position has
2139 return (Element => Position.Node.Element.all'Access);
2140 end Reference_Preserving_Key;
2142 function Reference_Preserving_Key
2143 (Container : aliased in out Set;
2144 Key : Key_Type) return Reference_Type
2146 Node : constant Node_Access :=
2147 Key_Keys.Find (Container.HT, Key);
2151 raise Constraint_Error with "Key not in set";
2154 if Node.Element = null then
2155 raise Program_Error with "Node has no element";
2158 -- Some form of finalization will be required in order to actually
2159 -- check that the key-part of the element designated by Key has not
2162 return (Element => Node.Element.all'Access);
2163 end Reference_Preserving_Key;
2170 (Container : in out Set;
2172 New_Item : Element_Type)
2174 Node : constant Node_Access :=
2175 Key_Keys.Find (Container.HT, Key);
2179 raise Constraint_Error with
2180 "attempt to replace key not in set";
2183 Replace_Element (Container.HT, Node, New_Item);
2186 -----------------------------------
2187 -- Update_Element_Preserving_Key --
2188 -----------------------------------
2190 procedure Update_Element_Preserving_Key
2191 (Container : in out Set;
2193 Process : not null access
2194 procedure (Element : in out Element_Type))
2196 HT : Hash_Table_Type renames Container.HT;
2200 if Position.Node = null then
2201 raise Constraint_Error with
2202 "Position cursor equals No_Element";
2205 if Position.Node.Element = null
2206 or else Position.Node.Next = Position.Node
2208 raise Program_Error with "Position cursor is bad";
2211 if Position.Container /= Container'Unrestricted_Access then
2212 raise Program_Error with
2213 "Position cursor designates wrong set";
2216 if HT.Buckets = null
2217 or else HT.Buckets'Length = 0
2218 or else HT.Length = 0
2220 raise Program_Error with "Position cursor is bad (set is empty)";
2225 "bad cursor in Update_Element_Preserving_Key");
2227 Indx := HT_Ops.Index (HT, Position.Node);
2230 E : Element_Type renames Position.Node.Element.all;
2231 K : constant Key_Type := Key (E);
2233 B : Natural renames HT.Busy;
2234 L : Natural renames HT.Lock;
2252 if Equivalent_Keys (K, Key (E)) then
2253 pragma Assert (Hash (K) = Hash (E));
2258 if HT.Buckets (Indx) = Position.Node then
2259 HT.Buckets (Indx) := Position.Node.Next;
2263 Prev : Node_Access := HT.Buckets (Indx);
2266 while Prev.Next /= Position.Node loop
2270 raise Program_Error with
2271 "Position cursor is bad (node not found)";
2275 Prev.Next := Position.Node.Next;
2279 HT.Length := HT.Length - 1;
2282 X : Node_Access := Position.Node;
2288 raise Program_Error with "key was modified";
2289 end Update_Element_Preserving_Key;
2296 (Stream : not null access Root_Stream_Type'Class;
2297 Item : Reference_Type)
2300 raise Program_Error with "attempt to stream reference";
2305 end Ada.Containers.Indefinite_Hashed_Sets;