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-2013, 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
);
153 procedure Adjust
(Control
: in out Reference_Control_Type
) is
155 if Control
.Container
/= null then
157 HT
: Hash_Table_Type
renames Control
.Container
.all.HT
;
158 B
: Natural renames HT
.Busy
;
159 L
: Natural renames HT
.Lock
;
171 procedure Assign
(Node
: Node_Access
; Item
: Element_Type
) is
173 Node
.Element
:= Item
;
176 procedure Assign
(Target
: in out Set
; Source
: Set
) is
178 if Target
'Address = Source
'Address then
183 Target
.Union
(Source
);
190 function Capacity
(Container
: Set
) return Count_Type
is
192 return HT_Ops
.Capacity
(Container
.HT
);
199 procedure Clear
(Container
: in out Set
) is
201 HT_Ops
.Clear
(Container
.HT
);
204 ------------------------
205 -- Constant_Reference --
206 ------------------------
208 function Constant_Reference
209 (Container
: aliased Set
;
210 Position
: Cursor
) return Constant_Reference_Type
213 if Position
.Container
= null then
214 raise Constraint_Error
with "Position cursor has no element";
217 if Position
.Container
/= Container
'Unrestricted_Access then
218 raise Program_Error
with
219 "Position cursor designates wrong container";
222 pragma Assert
(Vet
(Position
), "bad cursor in Constant_Reference");
225 HT
: Hash_Table_Type
renames Position
.Container
.all.HT
;
226 B
: Natural renames HT
.Busy
;
227 L
: Natural renames HT
.Lock
;
229 return R
: constant Constant_Reference_Type
:=
230 (Element
=> Position
.Node
.Element
'Access,
231 Control
=> (Controlled
with Container
'Unrestricted_Access))
237 end Constant_Reference
;
243 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean is
245 return Find
(Container
, Item
) /= No_Element
;
254 Capacity
: Count_Type
:= 0) return Set
262 elsif Capacity
>= Source
.Length
then
267 with "Requested capacity is less than Source length";
270 return Target
: Set
do
271 Target
.Reserve_Capacity
(C
);
272 Target
.Assign
(Source
);
280 function Copy_Node
(Source
: Node_Access
) return Node_Access
is
282 return new Node_Type
'(Element => Source.Element, Next => null);
290 (Container : in out Set;
296 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
299 raise Constraint_Error with "attempt to delete element not in set";
306 (Container : in out Set;
307 Position : in out Cursor)
310 if Position.Node = null then
311 raise Constraint_Error with "Position cursor equals No_Element";
314 if Position.Container /= Container'Unrestricted_Access then
315 raise Program_Error with "Position cursor designates wrong set";
318 if Container.HT.Busy > 0 then
319 raise Program_Error with
320 "attempt to tamper with cursors (set is busy)";
323 pragma Assert (Vet (Position), "bad cursor in Delete");
325 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
327 Free (Position.Node);
328 Position.Container := null;
336 (Target : in out Set;
339 Tgt_Node : Node_Access;
342 if Target'Address = Source'Address then
347 if Source.HT.Length = 0 then
351 if Target.HT.Busy > 0 then
352 raise Program_Error with
353 "attempt to tamper with cursors (set is busy)";
356 if Source.HT.Length < Target.HT.Length then
358 Src_Node : Node_Access;
361 Src_Node := HT_Ops.First (Source.HT);
362 while Src_Node /= null loop
363 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element);
365 if Tgt_Node /= null then
366 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
370 Src_Node := HT_Ops.Next (Source.HT, Src_Node);
375 Tgt_Node := HT_Ops.First (Target.HT);
376 while Tgt_Node /= null loop
377 if Is_In (Source.HT, Tgt_Node) then
379 X : Node_Access := Tgt_Node;
381 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
382 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
387 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
393 function Difference (Left, Right : Set) return Set is
394 Buckets : HT_Types.Buckets_Access;
398 if Left'Address = Right'Address then
402 if Left.HT.Length = 0 then
406 if Right.HT.Length = 0 then
411 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
413 Buckets := HT_Ops.New_Buckets (Length => Size);
418 Iterate_Left : declare
419 procedure Process (L_Node : Node_Access);
422 new HT_Ops.Generic_Iteration (Process);
428 procedure Process (L_Node : Node_Access) is
430 if not Is_In (Right.HT, L_Node) then
432 J : constant Hash_Type :=
433 Hash (L_Node.Element) mod Buckets'Length;
435 Bucket : Node_Access renames Buckets (J);
438 Bucket := new Node_Type'(L_Node
.Element
, Bucket
);
441 Length
:= Length
+ 1;
445 -- Start of processing for Iterate_Left
451 HT_Ops
.Free_Hash_Table
(Buckets
);
455 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
462 function Element
(Position
: Cursor
) return Element_Type
is
464 if Position
.Node
= null then
465 raise Constraint_Error
with "Position cursor equals No_Element";
468 pragma Assert
(Vet
(Position
), "bad cursor in function Element");
470 return Position
.Node
.Element
;
473 ---------------------
474 -- Equivalent_Sets --
475 ---------------------
477 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
479 return Is_Equivalent
(Left
.HT
, Right
.HT
);
482 -------------------------
483 -- Equivalent_Elements --
484 -------------------------
486 function Equivalent_Elements
(Left
, Right
: Cursor
)
489 if Left
.Node
= null then
490 raise Constraint_Error
with
491 "Left cursor of Equivalent_Elements equals No_Element";
494 if Right
.Node
= null then
495 raise Constraint_Error
with
496 "Right cursor of Equivalent_Elements equals No_Element";
499 pragma Assert
(Vet
(Left
), "bad Left cursor in Equivalent_Elements");
500 pragma Assert
(Vet
(Right
), "bad Right cursor in Equivalent_Elements");
502 return Equivalent_Elements
(Left
.Node
.Element
, Right
.Node
.Element
);
503 end Equivalent_Elements
;
505 function Equivalent_Elements
(Left
: Cursor
; Right
: Element_Type
)
508 if Left
.Node
= null then
509 raise Constraint_Error
with
510 "Left cursor of Equivalent_Elements equals No_Element";
513 pragma Assert
(Vet
(Left
), "Left cursor in Equivalent_Elements is bad");
515 return Equivalent_Elements
(Left
.Node
.Element
, Right
);
516 end Equivalent_Elements
;
518 function Equivalent_Elements
(Left
: Element_Type
; Right
: Cursor
)
521 if Right
.Node
= null then
522 raise Constraint_Error
with
523 "Right cursor of Equivalent_Elements equals No_Element";
528 "Right cursor of Equivalent_Elements is bad");
530 return Equivalent_Elements
(Left
, Right
.Node
.Element
);
531 end Equivalent_Elements
;
533 ---------------------
534 -- Equivalent_Keys --
535 ---------------------
537 function Equivalent_Keys
(Key
: Element_Type
; Node
: Node_Access
)
540 return Equivalent_Elements
(Key
, Node
.Element
);
548 (Container
: in out Set
;
553 Element_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Item
, X
);
561 procedure Finalize
(Container
: in out Set
) is
563 HT_Ops
.Finalize
(Container
.HT
);
566 procedure Finalize
(Control
: in out Reference_Control_Type
) is
568 if Control
.Container
/= null then
570 HT
: Hash_Table_Type
renames Control
.Container
.all.HT
;
571 B
: Natural renames HT
.Busy
;
572 L
: Natural renames HT
.Lock
;
578 Control
.Container
:= null;
588 Item
: Element_Type
) return Cursor
590 Node
: constant Node_Access
:= Element_Keys
.Find
(Container
.HT
, Item
);
597 return Cursor
'(Container'Unrestricted_Access, Node);
604 function Find_Equal_Key
605 (R_HT : Hash_Table_Type;
606 L_Node : Node_Access) return Boolean
608 R_Index : constant Hash_Type :=
609 Element_Keys.Index (R_HT, L_Node.Element);
611 R_Node : Node_Access := R_HT.Buckets (R_Index);
615 if R_Node = null then
619 if L_Node.Element = R_Node.Element then
623 R_Node := Next (R_Node);
627 -------------------------
628 -- Find_Equivalent_Key --
629 -------------------------
631 function Find_Equivalent_Key
632 (R_HT : Hash_Table_Type;
633 L_Node : Node_Access) return Boolean
635 R_Index : constant Hash_Type :=
636 Element_Keys.Index (R_HT, L_Node.Element);
638 R_Node : Node_Access := R_HT.Buckets (R_Index);
642 if R_Node = null then
646 if Equivalent_Elements (L_Node.Element, R_Node.Element) then
650 R_Node := Next (R_Node);
652 end Find_Equivalent_Key;
658 function First (Container : Set) return Cursor is
659 Node : constant Node_Access := HT_Ops.First (Container.HT);
666 return Cursor'(Container
'Unrestricted_Access, Node
);
669 function First
(Object
: Iterator
) return Cursor
is
671 return Object
.Container
.First
;
678 procedure Free
(X
: in out Node_Access
) is
679 procedure Deallocate
is
680 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
684 X
.Next
:= X
; -- detect mischief (in Vet)
693 function Has_Element
(Position
: Cursor
) return Boolean is
695 pragma Assert
(Vet
(Position
), "bad cursor in Has_Element");
696 return Position
.Node
/= null;
703 function Hash_Node
(Node
: Node_Access
) return Hash_Type
is
705 return Hash
(Node
.Element
);
713 (Container
: in out Set
;
714 New_Item
: Element_Type
)
720 Insert
(Container
, New_Item
, Position
, Inserted
);
723 if Container
.HT
.Lock
> 0 then
724 raise Program_Error
with
725 "attempt to tamper with elements (set is locked)";
728 Position
.Node
.Element
:= New_Item
;
737 (Container
: in out Set
;
738 New_Item
: Element_Type
;
739 Position
: out Cursor
;
740 Inserted
: out Boolean)
743 Insert
(Container
.HT
, New_Item
, Position
.Node
, Inserted
);
744 Position
.Container
:= Container
'Unchecked_Access;
748 (Container
: in out Set
;
749 New_Item
: Element_Type
)
752 pragma Unreferenced
(Position
);
757 Insert
(Container
, New_Item
, Position
, Inserted
);
760 raise Constraint_Error
with
761 "attempt to insert element already in set";
766 (HT
: in out Hash_Table_Type
;
767 New_Item
: Element_Type
;
768 Node
: out Node_Access
;
769 Inserted
: out Boolean)
771 function New_Node
(Next
: Node_Access
) return Node_Access
;
772 pragma Inline
(New_Node
);
774 procedure Local_Insert
is
775 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
781 function New_Node
(Next
: Node_Access
) return Node_Access
is
783 return new Node_Type
'(New_Item, Next);
786 -- Start of processing for Insert
789 if HT_Ops.Capacity (HT) = 0 then
790 HT_Ops.Reserve_Capacity (HT, 1);
793 Local_Insert (HT, New_Item, Node, Inserted);
796 and then HT.Length > HT_Ops.Capacity (HT)
798 HT_Ops.Reserve_Capacity (HT, HT.Length);
806 procedure Intersection
807 (Target : in out Set;
810 Tgt_Node : Node_Access;
813 if Target'Address = Source'Address then
817 if Source.HT.Length = 0 then
822 if Target.HT.Busy > 0 then
823 raise Program_Error with
824 "attempt to tamper with cursors (set is busy)";
827 Tgt_Node := HT_Ops.First (Target.HT);
828 while Tgt_Node /= null loop
829 if Is_In (Source.HT, Tgt_Node) then
830 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
834 X : Node_Access := Tgt_Node;
836 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
837 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
844 function Intersection (Left, Right : Set) return Set is
845 Buckets : HT_Types.Buckets_Access;
849 if Left'Address = Right'Address then
853 Length := Count_Type'Min (Left.Length, Right.Length);
860 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
862 Buckets := HT_Ops.New_Buckets (Length => Size);
867 Iterate_Left : declare
868 procedure Process (L_Node : Node_Access);
871 new HT_Ops.Generic_Iteration (Process);
877 procedure Process (L_Node : Node_Access) is
879 if Is_In (Right.HT, L_Node) then
881 J : constant Hash_Type :=
882 Hash (L_Node.Element) mod Buckets'Length;
884 Bucket : Node_Access renames Buckets (J);
887 Bucket := new Node_Type'(L_Node
.Element
, Bucket
);
890 Length
:= Length
+ 1;
894 -- Start of processing for Iterate_Left
900 HT_Ops
.Free_Hash_Table
(Buckets
);
904 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
911 function Is_Empty
(Container
: Set
) return Boolean is
913 return Container
.HT
.Length
= 0;
920 function Is_In
(HT
: Hash_Table_Type
; Key
: Node_Access
) return Boolean is
922 return Element_Keys
.Find
(HT
, Key
.Element
) /= null;
929 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
930 Subset_Node
: Node_Access
;
933 if Subset
'Address = Of_Set
'Address then
937 if Subset
.Length
> Of_Set
.Length
then
941 Subset_Node
:= HT_Ops
.First
(Subset
.HT
);
942 while Subset_Node
/= null loop
943 if not Is_In
(Of_Set
.HT
, Subset_Node
) then
946 Subset_Node
:= HT_Ops
.Next
(Subset
.HT
, Subset_Node
);
958 Process
: not null access procedure (Position
: Cursor
))
960 procedure Process_Node
(Node
: Node_Access
);
961 pragma Inline
(Process_Node
);
964 new HT_Ops
.Generic_Iteration
(Process_Node
);
970 procedure Process_Node
(Node
: Node_Access
) is
972 Process
(Cursor
'(Container'Unrestricted_Access, Node));
975 B : Natural renames Container'Unrestricted_Access.HT.Busy;
977 -- Start of processing for Iterate
983 Iterate (Container.HT);
994 (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class
997 return Iterator'(Container
=> Container
'Unrestricted_Access);
1004 function Length
(Container
: Set
) return Count_Type
is
1006 return Container
.HT
.Length
;
1013 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1015 HT_Ops
.Move
(Target
=> Target
.HT
, Source
=> Source
.HT
);
1022 function Next
(Node
: Node_Access
) return Node_Access
is
1027 function Next
(Position
: Cursor
) return Cursor
is
1029 if Position
.Node
= null then
1033 pragma Assert
(Vet
(Position
), "bad cursor in Next");
1036 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
1037 Node
: constant Node_Access
:= HT_Ops
.Next
(HT
, Position
.Node
);
1044 return Cursor
'(Position.Container, Node);
1048 procedure Next (Position : in out Cursor) is
1050 Position := Next (Position);
1055 Position : Cursor) return Cursor
1058 if Position.Container = null then
1062 if Position.Container /= Object.Container then
1063 raise Program_Error with
1064 "Position cursor of Next designates wrong set";
1067 return Next (Position);
1074 function Overlap (Left, Right : Set) return Boolean is
1075 Left_Node : Node_Access;
1078 if Right.Length = 0 then
1082 if Left'Address = Right'Address then
1086 Left_Node := HT_Ops.First (Left.HT);
1087 while Left_Node /= null loop
1088 if Is_In (Right.HT, Left_Node) then
1091 Left_Node := HT_Ops.Next (Left.HT, Left_Node);
1101 procedure Query_Element
1103 Process : not null access procedure (Element : Element_Type))
1106 if Position.Node = null then
1107 raise Constraint_Error with
1108 "Position cursor of Query_Element equals No_Element";
1111 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1114 HT : Hash_Table_Type renames Position.Container.HT;
1116 B : Natural renames HT.Busy;
1117 L : Natural renames HT.Lock;
1124 Process (Position.Node.Element);
1142 (Stream : not null access Root_Stream_Type'Class;
1143 Container : out Set)
1146 Read_Nodes (Stream, Container.HT);
1150 (Stream : not null access Root_Stream_Type'Class;
1154 raise Program_Error with "attempt to stream set cursor";
1158 (Stream : not null access Root_Stream_Type'Class;
1159 Item : out Constant_Reference_Type)
1162 raise Program_Error with "attempt to stream reference";
1169 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1172 Node : Node_Access := new Node_Type;
1175 Element_Type'Read (Stream, Node.Element);
1188 (Container : in out Set;
1189 New_Item : Element_Type)
1191 Node : constant Node_Access :=
1192 Element_Keys.Find (Container.HT, New_Item);
1196 raise Constraint_Error with
1197 "attempt to replace element not in set";
1200 if Container.HT.Lock > 0 then
1201 raise Program_Error with
1202 "attempt to tamper with elements (set is locked)";
1205 Node.Element := New_Item;
1208 procedure Replace_Element
1209 (Container : in out Set;
1211 New_Item : Element_Type)
1214 if Position.Node = null then
1215 raise Constraint_Error with
1216 "Position cursor equals No_Element";
1219 if Position.Container /= Container'Unrestricted_Access then
1220 raise Program_Error with
1221 "Position cursor designates wrong set";
1224 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1226 Replace_Element (Container.HT, Position.Node, New_Item);
1227 end Replace_Element;
1229 ----------------------
1230 -- Reserve_Capacity --
1231 ----------------------
1233 procedure Reserve_Capacity
1234 (Container : in out Set;
1235 Capacity : Count_Type)
1238 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1239 end Reserve_Capacity;
1245 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1250 --------------------------
1251 -- Symmetric_Difference --
1252 --------------------------
1254 procedure Symmetric_Difference
1255 (Target : in out Set;
1259 if Target'Address = Source'Address then
1264 if Target.HT.Busy > 0 then
1265 raise Program_Error with
1266 "attempt to tamper with cursors (set is busy)";
1270 N : constant Count_Type := Target.Length + Source.Length;
1272 if N > HT_Ops.Capacity (Target.HT) then
1273 HT_Ops.Reserve_Capacity (Target.HT, N);
1277 if Target.Length = 0 then
1278 Iterate_Source_When_Empty_Target : declare
1279 procedure Process (Src_Node : Node_Access);
1281 procedure Iterate is
1282 new HT_Ops.Generic_Iteration (Process);
1288 procedure Process (Src_Node : Node_Access) is
1289 E : Element_Type renames Src_Node.Element;
1290 B : Buckets_Type renames Target.HT.Buckets.all;
1291 J : constant Hash_Type := Hash (E) mod B'Length;
1292 N : Count_Type renames Target.HT.Length;
1295 B (J) := new Node_Type'(E
, B
(J
));
1299 -- Start of processing for Iterate_Source_When_Empty_Target
1302 Iterate
(Source
.HT
);
1303 end Iterate_Source_When_Empty_Target
;
1306 Iterate_Source
: declare
1307 procedure Process
(Src_Node
: Node_Access
);
1309 procedure Iterate
is
1310 new HT_Ops
.Generic_Iteration
(Process
);
1316 procedure Process
(Src_Node
: Node_Access
) is
1317 E
: Element_Type
renames Src_Node
.Element
;
1318 B
: Buckets_Type
renames Target
.HT
.Buckets
.all;
1319 J
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
1320 N
: Count_Type
renames Target
.HT
.Length
;
1323 if B
(J
) = null then
1324 B
(J
) := new Node_Type
'(E, null);
1327 elsif Equivalent_Elements (E, B (J).Element) then
1329 X : Node_Access := B (J);
1331 B (J) := B (J).Next;
1338 Prev : Node_Access := B (J);
1339 Curr : Node_Access := Prev.Next;
1342 while Curr /= null loop
1343 if Equivalent_Elements (E, Curr.Element) then
1344 Prev.Next := Curr.Next;
1354 B (J) := new Node_Type'(E
, B
(J
));
1360 -- Start of processing for Iterate_Source
1363 Iterate
(Source
.HT
);
1366 end Symmetric_Difference
;
1368 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
1369 Buckets
: HT_Types
.Buckets_Access
;
1370 Length
: Count_Type
;
1373 if Left
'Address = Right
'Address then
1377 if Right
.Length
= 0 then
1381 if Left
.Length
= 0 then
1386 Size
: constant Hash_Type
:=
1387 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1389 Buckets
:= HT_Ops
.New_Buckets
(Length
=> Size
);
1394 Iterate_Left
: declare
1395 procedure Process
(L_Node
: Node_Access
);
1397 procedure Iterate
is
1398 new HT_Ops
.Generic_Iteration
(Process
);
1404 procedure Process
(L_Node
: Node_Access
) is
1406 if not Is_In
(Right
.HT
, L_Node
) then
1408 E
: Element_Type
renames L_Node
.Element
;
1409 J
: constant Hash_Type
:= Hash
(E
) mod Buckets
'Length;
1412 Buckets
(J
) := new Node_Type
'(E, Buckets (J));
1413 Length := Length + 1;
1418 -- Start of processing for Iterate_Left
1424 HT_Ops.Free_Hash_Table (Buckets);
1428 Iterate_Right : declare
1429 procedure Process (R_Node : Node_Access);
1431 procedure Iterate is
1432 new HT_Ops.Generic_Iteration (Process);
1438 procedure Process (R_Node : Node_Access) is
1440 if not Is_In (Left.HT, R_Node) then
1442 E : Element_Type renames R_Node.Element;
1443 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1446 Buckets (J) := new Node_Type'(E
, Buckets
(J
));
1447 Length
:= Length
+ 1;
1452 -- Start of processing for Iterate_Right
1458 HT_Ops
.Free_Hash_Table
(Buckets
);
1462 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
1463 end Symmetric_Difference
;
1469 function To_Set
(New_Item
: Element_Type
) return Set
is
1470 HT
: Hash_Table_Type
;
1474 pragma Unreferenced
(Node
, Inserted
);
1477 Insert
(HT
, New_Item
, Node
, Inserted
);
1478 return Set
'(Controlled with HT);
1486 (Target : in out Set;
1489 procedure Process (Src_Node : Node_Access);
1491 procedure Iterate is
1492 new HT_Ops.Generic_Iteration (Process);
1498 procedure Process (Src_Node : Node_Access) is
1499 function New_Node (Next : Node_Access) return Node_Access;
1500 pragma Inline (New_Node);
1503 new Element_Keys.Generic_Conditional_Insert (New_Node);
1509 function New_Node (Next : Node_Access) return Node_Access is
1510 Node : constant Node_Access :=
1511 new Node_Type'(Src_Node
.Element
, Next
);
1516 Tgt_Node
: Node_Access
;
1518 pragma Unreferenced
(Tgt_Node
, Success
);
1520 -- Start of processing for Process
1523 Insert
(Target
.HT
, Src_Node
.Element
, Tgt_Node
, Success
);
1526 -- Start of processing for Union
1529 if Target
'Address = Source
'Address then
1533 if Target
.HT
.Busy
> 0 then
1534 raise Program_Error
with
1535 "attempt to tamper with cursors (set is busy)";
1539 N
: constant Count_Type
:= Target
.Length
+ Source
.Length
;
1541 if N
> HT_Ops
.Capacity
(Target
.HT
) then
1542 HT_Ops
.Reserve_Capacity
(Target
.HT
, N
);
1546 Iterate
(Source
.HT
);
1549 function Union
(Left
, Right
: Set
) return Set
is
1550 Buckets
: HT_Types
.Buckets_Access
;
1551 Length
: Count_Type
;
1554 if Left
'Address = Right
'Address then
1558 if Right
.Length
= 0 then
1562 if Left
.Length
= 0 then
1567 Size
: constant Hash_Type
:=
1568 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1570 Buckets
:= HT_Ops
.New_Buckets
(Length
=> Size
);
1573 Iterate_Left
: declare
1574 procedure Process
(L_Node
: Node_Access
);
1576 procedure Iterate
is
1577 new HT_Ops
.Generic_Iteration
(Process
);
1583 procedure Process
(L_Node
: Node_Access
) is
1584 J
: constant Hash_Type
:=
1585 Hash
(L_Node
.Element
) mod Buckets
'Length;
1588 Buckets
(J
) := new Node_Type
'(L_Node.Element, Buckets (J));
1591 -- Start of processing for Iterate_Left
1597 HT_Ops.Free_Hash_Table (Buckets);
1601 Length := Left.Length;
1603 Iterate_Right : declare
1604 procedure Process (Src_Node : Node_Access);
1606 procedure Iterate is
1607 new HT_Ops.Generic_Iteration (Process);
1613 procedure Process (Src_Node : Node_Access) is
1614 J : constant Hash_Type :=
1615 Hash (Src_Node.Element) mod Buckets'Length;
1617 Tgt_Node : Node_Access := Buckets (J);
1620 while Tgt_Node /= null loop
1621 if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1625 Tgt_Node := Next (Tgt_Node);
1628 Buckets (J) := new Node_Type'(Src_Node
.Element
, Buckets
(J
));
1629 Length
:= Length
+ 1;
1632 -- Start of processing for Iterate_Right
1638 HT_Ops
.Free_Hash_Table
(Buckets
);
1642 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
1649 function Vet
(Position
: Cursor
) return Boolean is
1651 if Position
.Node
= null then
1652 return Position
.Container
= null;
1655 if Position
.Container
= null then
1659 if Position
.Node
.Next
= Position
.Node
then
1664 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
1668 if HT
.Length
= 0 then
1672 if HT
.Buckets
= null
1673 or else HT
.Buckets
'Length = 0
1678 X
:= HT
.Buckets
(Element_Keys
.Index
(HT
, Position
.Node
.Element
));
1680 for J
in 1 .. HT
.Length
loop
1681 if X
= Position
.Node
then
1689 if X
= X
.Next
then -- to prevent unnecessary looping
1705 (Stream
: not null access Root_Stream_Type
'Class;
1709 Write_Nodes
(Stream
, Container
.HT
);
1713 (Stream
: not null access Root_Stream_Type
'Class;
1717 raise Program_Error
with "attempt to stream set cursor";
1721 (Stream
: not null access Root_Stream_Type
'Class;
1722 Item
: Constant_Reference_Type
)
1725 raise Program_Error
with "attempt to stream reference";
1732 procedure Write_Node
1733 (Stream
: not null access Root_Stream_Type
'Class;
1737 Element_Type
'Write (Stream
, Node
.Element
);
1740 package body Generic_Keys
is
1742 -----------------------
1743 -- Local Subprograms --
1744 -----------------------
1746 function Equivalent_Key_Node
1748 Node
: Node_Access
) return Boolean;
1749 pragma Inline
(Equivalent_Key_Node
);
1751 --------------------------
1752 -- Local Instantiations --
1753 --------------------------
1756 new Hash_Tables
.Generic_Keys
1757 (HT_Types
=> HT_Types
,
1759 Set_Next
=> Set_Next
,
1760 Key_Type
=> Key_Type
,
1762 Equivalent_Keys
=> Equivalent_Key_Node
);
1764 ------------------------
1765 -- Constant_Reference --
1766 ------------------------
1768 function Constant_Reference
1769 (Container
: aliased Set
;
1770 Key
: Key_Type
) return Constant_Reference_Type
1772 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.HT
, Key
);
1776 raise Constraint_Error
with "Key not in set";
1780 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.all.HT
;
1781 B
: Natural renames HT
.Busy
;
1782 L
: Natural renames HT
.Lock
;
1784 return R
: constant Constant_Reference_Type
:=
1785 (Element
=> Node
.Element
'Access,
1786 Control
=> (Controlled
with Container
'Unrestricted_Access))
1792 end Constant_Reference
;
1800 Key
: Key_Type
) return Boolean
1803 return Find
(Container
, Key
) /= No_Element
;
1811 (Container
: in out Set
;
1817 Key_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Key
, X
);
1820 raise Constraint_Error
with "attempt to delete key not in set";
1832 Key
: Key_Type
) return Element_Type
1834 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.HT
, Key
);
1838 raise Constraint_Error
with "key not in map"; -- ??? "set"
1841 return Node
.Element
;
1844 -------------------------
1845 -- Equivalent_Key_Node --
1846 -------------------------
1848 function Equivalent_Key_Node
1850 Node
: Node_Access
) return Boolean
1853 return Equivalent_Keys
(Key
, Generic_Keys
.Key
(Node
.Element
));
1854 end Equivalent_Key_Node
;
1861 (Container
: in out Set
;
1866 Key_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Key
, X
);
1876 Key
: Key_Type
) return Cursor
1878 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.HT
, Key
);
1885 return Cursor
'(Container'Unrestricted_Access, Node);
1892 function Key (Position : Cursor) return Key_Type is
1894 if Position.Node = null then
1895 raise Constraint_Error with
1896 "Position cursor equals No_Element";
1899 pragma Assert (Vet (Position), "bad cursor in function Key");
1901 return Key (Position.Node.Element);
1909 (Stream : not null access Root_Stream_Type'Class;
1910 Item : out Reference_Type)
1913 raise Program_Error with "attempt to stream reference";
1916 ------------------------------
1917 -- Reference_Preserving_Key --
1918 ------------------------------
1920 function Reference_Preserving_Key
1921 (Container : aliased in out Set;
1922 Position : Cursor) return Reference_Type
1925 if Position.Container = null then
1926 raise Constraint_Error with "Position cursor has no element";
1929 if Position.Container /= Container'Unrestricted_Access then
1930 raise Program_Error with
1931 "Position cursor designates wrong container";
1936 "bad cursor in function Reference_Preserving_Key");
1938 -- Some form of finalization will be required in order to actually
1939 -- check that the key-part of the element designated by Position has
1942 return (Element => Position.Node.Element'Access);
1943 end Reference_Preserving_Key;
1945 function Reference_Preserving_Key
1946 (Container : aliased in out Set;
1947 Key : Key_Type) return Reference_Type
1949 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1953 raise Constraint_Error with "Key not in set";
1956 -- Some form of finalization will be required in order to actually
1957 -- check that the key-part of the element designated by Key has not
1960 return (Element => Node.Element'Access);
1961 end Reference_Preserving_Key;
1968 (Container : in out Set;
1970 New_Item : Element_Type)
1972 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1976 raise Constraint_Error with
1977 "attempt to replace key not in set";
1980 Replace_Element (Container.HT, Node, New_Item);
1983 -----------------------------------
1984 -- Update_Element_Preserving_Key --
1985 -----------------------------------
1987 procedure Update_Element_Preserving_Key
1988 (Container : in out Set;
1990 Process : not null access
1991 procedure (Element : in out Element_Type))
1993 HT : Hash_Table_Type renames Container.HT;
1997 if Position.Node = null then
1998 raise Constraint_Error with
1999 "Position cursor equals No_Element";
2002 if Position.Container /= Container'Unrestricted_Access then
2003 raise Program_Error with
2004 "Position cursor designates wrong set";
2007 if HT.Buckets = null
2008 or else HT.Buckets'Length = 0
2009 or else HT.Length = 0
2010 or else Position.Node.Next = Position.Node
2012 raise Program_Error with "Position cursor is bad (set is empty)";
2017 "bad cursor in Update_Element_Preserving_Key");
2019 Indx := HT_Ops.Index (HT, Position.Node);
2022 E : Element_Type renames Position.Node.Element;
2023 K : constant Key_Type := Key (E);
2025 B : Natural renames HT.Busy;
2026 L : Natural renames HT.Lock;
2044 if Equivalent_Keys (K, Key (E)) then
2045 pragma Assert (Hash (K) = Hash (E));
2050 if HT.Buckets (Indx) = Position.Node then
2051 HT.Buckets (Indx) := Position.Node.Next;
2055 Prev : Node_Access := HT.Buckets (Indx);
2058 while Prev.Next /= Position.Node loop
2062 raise Program_Error with
2063 "Position cursor is bad (node not found)";
2067 Prev.Next := Position.Node.Next;
2071 HT.Length := HT.Length - 1;
2074 X : Node_Access := Position.Node;
2080 raise Program_Error with "key was modified";
2081 end Update_Element_Preserving_Key;
2088 (Stream : not null access Root_Stream_Type'Class;
2089 Item : Reference_Type)
2092 raise Program_Error with "attempt to stream reference";
2097 end Ada.Containers.Hashed_Sets;