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-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- This unit has originally being developed by Matthew J Heaney. --
30 ------------------------------------------------------------------------------
32 with Ada
.Unchecked_Deallocation
;
34 with Ada
.Containers
.Hash_Tables
.Generic_Operations
;
35 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Operations
);
37 with Ada
.Containers
.Hash_Tables
.Generic_Keys
;
38 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Keys
);
40 with Ada
.Containers
.Prime_Numbers
;
42 with System
; use type System
.Address
;
44 package body Ada
.Containers
.Hashed_Sets
is
46 -----------------------
47 -- Local Subprograms --
48 -----------------------
50 procedure Assign
(Node
: Node_Access
; Item
: Element_Type
);
51 pragma Inline
(Assign
);
53 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
54 pragma Inline
(Copy_Node
);
56 function Equivalent_Keys
58 Node
: Node_Access
) return Boolean;
59 pragma Inline
(Equivalent_Keys
);
61 function Find_Equal_Key
62 (R_HT
: Hash_Table_Type
;
63 L_Node
: Node_Access
) return Boolean;
65 function Find_Equivalent_Key
66 (R_HT
: Hash_Table_Type
;
67 L_Node
: Node_Access
) return Boolean;
69 procedure Free
(X
: in out Node_Access
);
71 function Hash_Node
(Node
: Node_Access
) return Hash_Type
;
72 pragma Inline
(Hash_Node
);
75 (HT
: in out Hash_Table_Type
;
76 New_Item
: Element_Type
;
77 Node
: out Node_Access
;
78 Inserted
: out Boolean);
81 (HT
: Hash_Table_Type
;
82 Key
: Node_Access
) return Boolean;
83 pragma Inline
(Is_In
);
85 function Next
(Node
: Node_Access
) return Node_Access
;
88 function Read_Node
(Stream
: not null access Root_Stream_Type
'Class)
90 pragma Inline
(Read_Node
);
92 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
);
93 pragma Inline
(Set_Next
);
95 function Vet
(Position
: Cursor
) return Boolean;
98 (Stream
: not null access Root_Stream_Type
'Class;
100 pragma Inline
(Write_Node
);
102 --------------------------
103 -- Local Instantiations --
104 --------------------------
107 new Hash_Tables
.Generic_Operations
108 (HT_Types
=> HT_Types
,
109 Hash_Node
=> Hash_Node
,
111 Set_Next
=> Set_Next
,
112 Copy_Node
=> Copy_Node
,
115 package Element_Keys
is
116 new Hash_Tables
.Generic_Keys
117 (HT_Types
=> HT_Types
,
119 Set_Next
=> Set_Next
,
120 Key_Type
=> Element_Type
,
122 Equivalent_Keys
=> Equivalent_Keys
);
125 new HT_Ops
.Generic_Equal
(Find_Equal_Key
);
127 function Is_Equivalent
is
128 new HT_Ops
.Generic_Equal
(Find_Equivalent_Key
);
130 procedure Read_Nodes
is
131 new HT_Ops
.Generic_Read
(Read_Node
);
133 procedure Replace_Element
is
134 new Element_Keys
.Generic_Replace_Element
(Hash_Node
, Assign
);
136 procedure Write_Nodes
is
137 new HT_Ops
.Generic_Write
(Write_Node
);
143 function "=" (Left
, Right
: Set
) return Boolean is
145 return Is_Equal
(Left
.HT
, Right
.HT
);
152 procedure Adjust
(Container
: in out Set
) is
154 HT_Ops
.Adjust
(Container
.HT
);
161 procedure Assign
(Node
: Node_Access
; Item
: Element_Type
) is
163 Node
.Element
:= Item
;
170 function Capacity
(Container
: Set
) return Count_Type
is
172 return HT_Ops
.Capacity
(Container
.HT
);
179 procedure Clear
(Container
: in out Set
) is
181 HT_Ops
.Clear
(Container
.HT
);
188 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean is
190 return Find
(Container
, Item
) /= No_Element
;
197 function Copy_Node
(Source
: Node_Access
) return Node_Access
is
199 return new Node_Type
'(Element => Source.Element, Next => null);
207 (Container : in out Set;
213 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
216 raise Constraint_Error with "attempt to delete element not in set";
223 (Container : in out Set;
224 Position : in out Cursor)
227 if Position.Node = null then
228 raise Constraint_Error with "Position cursor equals No_Element";
231 if Position.Container /= Container'Unrestricted_Access then
232 raise Program_Error with "Position cursor designates wrong set";
235 if Container.HT.Busy > 0 then
236 raise Program_Error with
237 "attempt to tamper with elements (set is busy)";
240 pragma Assert (Vet (Position), "bad cursor in Delete");
242 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
244 Free (Position.Node);
245 Position.Container := null;
253 (Target : in out Set;
256 Tgt_Node : Node_Access;
259 if Target'Address = Source'Address then
264 if Source.HT.Length = 0 then
268 if Target.HT.Busy > 0 then
269 raise Program_Error with
270 "attempt to tamper with elements (set is busy)";
273 if Source.HT.Length < Target.HT.Length then
275 Src_Node : Node_Access;
278 Src_Node := HT_Ops.First (Source.HT);
279 while Src_Node /= null loop
280 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element);
282 if Tgt_Node /= null then
283 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
287 Src_Node := HT_Ops.Next (Source.HT, Src_Node);
292 Tgt_Node := HT_Ops.First (Target.HT);
293 while Tgt_Node /= null loop
294 if Is_In (Source.HT, Tgt_Node) then
296 X : Node_Access := Tgt_Node;
298 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
299 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
304 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
310 function Difference (Left, Right : Set) return Set is
311 Buckets : HT_Types.Buckets_Access;
315 if Left'Address = Right'Address then
319 if Left.HT.Length = 0 then
323 if Right.HT.Length = 0 then
328 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
330 Buckets := HT_Ops.New_Buckets (Length => Size);
335 Iterate_Left : declare
336 procedure Process (L_Node : Node_Access);
339 new HT_Ops.Generic_Iteration (Process);
345 procedure Process (L_Node : Node_Access) is
347 if not Is_In (Right.HT, L_Node) then
349 J : constant Hash_Type :=
350 Hash (L_Node.Element) mod Buckets'Length;
352 Bucket : Node_Access renames Buckets (J);
355 Bucket := new Node_Type'(L_Node
.Element
, Bucket
);
358 Length
:= Length
+ 1;
362 -- Start of processing for Iterate_Left
368 HT_Ops
.Free_Hash_Table
(Buckets
);
372 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
379 function Element
(Position
: Cursor
) return Element_Type
is
381 if Position
.Node
= null then
382 raise Constraint_Error
with "Position cursor equals No_Element";
385 pragma Assert
(Vet
(Position
), "bad cursor in function Element");
387 return Position
.Node
.Element
;
390 ---------------------
391 -- Equivalent_Sets --
392 ---------------------
394 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
396 return Is_Equivalent
(Left
.HT
, Right
.HT
);
399 -------------------------
400 -- Equivalent_Elements --
401 -------------------------
403 function Equivalent_Elements
(Left
, Right
: Cursor
)
406 if Left
.Node
= null then
407 raise Constraint_Error
with
408 "Left cursor of Equivalent_Elements equals No_Element";
411 if Right
.Node
= null then
412 raise Constraint_Error
with
413 "Right cursor of Equivalent_Elements equals No_Element";
416 pragma Assert
(Vet
(Left
), "bad Left cursor in Equivalent_Elements");
417 pragma Assert
(Vet
(Right
), "bad Right cursor in Equivalent_Elements");
419 return Equivalent_Elements
(Left
.Node
.Element
, Right
.Node
.Element
);
420 end Equivalent_Elements
;
422 function Equivalent_Elements
(Left
: Cursor
; Right
: Element_Type
)
425 if Left
.Node
= null then
426 raise Constraint_Error
with
427 "Left cursor of Equivalent_Elements equals No_Element";
430 pragma Assert
(Vet
(Left
), "Left cursor in Equivalent_Elements is bad");
432 return Equivalent_Elements
(Left
.Node
.Element
, Right
);
433 end Equivalent_Elements
;
435 function Equivalent_Elements
(Left
: Element_Type
; Right
: Cursor
)
438 if Right
.Node
= null then
439 raise Constraint_Error
with
440 "Right cursor of Equivalent_Elements equals No_Element";
445 "Right cursor of Equivalent_Elements is bad");
447 return Equivalent_Elements
(Left
, Right
.Node
.Element
);
448 end Equivalent_Elements
;
450 ---------------------
451 -- Equivalent_Keys --
452 ---------------------
454 function Equivalent_Keys
(Key
: Element_Type
; Node
: Node_Access
)
457 return Equivalent_Elements
(Key
, Node
.Element
);
465 (Container
: in out Set
;
470 Element_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Item
, X
);
478 procedure Finalize
(Container
: in out Set
) is
480 HT_Ops
.Finalize
(Container
.HT
);
489 Item
: Element_Type
) return Cursor
491 Node
: constant Node_Access
:= Element_Keys
.Find
(Container
.HT
, Item
);
498 return Cursor
'(Container'Unrestricted_Access, Node);
505 function Find_Equal_Key
506 (R_HT : Hash_Table_Type;
507 L_Node : Node_Access) return Boolean
509 R_Index : constant Hash_Type :=
510 Element_Keys.Index (R_HT, L_Node.Element);
512 R_Node : Node_Access := R_HT.Buckets (R_Index);
516 if R_Node = null then
520 if L_Node.Element = R_Node.Element then
524 R_Node := Next (R_Node);
528 -------------------------
529 -- Find_Equivalent_Key --
530 -------------------------
532 function Find_Equivalent_Key
533 (R_HT : Hash_Table_Type;
534 L_Node : Node_Access) return Boolean
536 R_Index : constant Hash_Type :=
537 Element_Keys.Index (R_HT, L_Node.Element);
539 R_Node : Node_Access := R_HT.Buckets (R_Index);
543 if R_Node = null then
547 if Equivalent_Elements (L_Node.Element, R_Node.Element) then
551 R_Node := Next (R_Node);
553 end Find_Equivalent_Key;
559 function First (Container : Set) return Cursor is
560 Node : constant Node_Access := HT_Ops.First (Container.HT);
567 return Cursor'(Container
'Unrestricted_Access, Node
);
574 procedure Free
(X
: in out Node_Access
) is
575 procedure Deallocate
is
576 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
580 X
.Next
:= X
; -- detect mischief (in Vet)
589 function Has_Element
(Position
: Cursor
) return Boolean is
591 pragma Assert
(Vet
(Position
), "bad cursor in Has_Element");
592 return Position
.Node
/= null;
599 function Hash_Node
(Node
: Node_Access
) return Hash_Type
is
601 return Hash
(Node
.Element
);
609 (Container
: in out Set
;
610 New_Item
: Element_Type
)
616 Insert
(Container
, New_Item
, Position
, Inserted
);
619 if Container
.HT
.Lock
> 0 then
620 raise Program_Error
with
621 "attempt to tamper with cursors (set is locked)";
624 Position
.Node
.Element
:= New_Item
;
633 (Container
: in out Set
;
634 New_Item
: Element_Type
;
635 Position
: out Cursor
;
636 Inserted
: out Boolean)
639 Insert
(Container
.HT
, New_Item
, Position
.Node
, Inserted
);
640 Position
.Container
:= Container
'Unchecked_Access;
644 (Container
: in out Set
;
645 New_Item
: Element_Type
)
648 pragma Unreferenced
(Position
);
653 Insert
(Container
, New_Item
, Position
, Inserted
);
656 raise Constraint_Error
with
657 "attempt to insert element already in set";
662 (HT
: in out Hash_Table_Type
;
663 New_Item
: Element_Type
;
664 Node
: out Node_Access
;
665 Inserted
: out Boolean)
667 function New_Node
(Next
: Node_Access
) return Node_Access
;
668 pragma Inline
(New_Node
);
670 procedure Local_Insert
is
671 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
677 function New_Node
(Next
: Node_Access
) return Node_Access
is
679 return new Node_Type
'(New_Item, Next);
682 -- Start of processing for Insert
685 if HT_Ops.Capacity (HT) = 0 then
686 HT_Ops.Reserve_Capacity (HT, 1);
689 Local_Insert (HT, New_Item, Node, Inserted);
692 and then HT.Length > HT_Ops.Capacity (HT)
694 HT_Ops.Reserve_Capacity (HT, HT.Length);
702 procedure Intersection
703 (Target : in out Set;
706 Tgt_Node : Node_Access;
709 if Target'Address = Source'Address then
713 if Source.HT.Length = 0 then
718 if Target.HT.Busy > 0 then
719 raise Program_Error with
720 "attempt to tamper with elements (set is busy)";
723 Tgt_Node := HT_Ops.First (Target.HT);
724 while Tgt_Node /= null loop
725 if Is_In (Source.HT, Tgt_Node) then
726 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
730 X : Node_Access := Tgt_Node;
732 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
733 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
740 function Intersection (Left, Right : Set) return Set is
741 Buckets : HT_Types.Buckets_Access;
745 if Left'Address = Right'Address then
749 Length := Count_Type'Min (Left.Length, Right.Length);
756 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
758 Buckets := HT_Ops.New_Buckets (Length => Size);
763 Iterate_Left : declare
764 procedure Process (L_Node : Node_Access);
767 new HT_Ops.Generic_Iteration (Process);
773 procedure Process (L_Node : Node_Access) is
775 if Is_In (Right.HT, L_Node) then
777 J : constant Hash_Type :=
778 Hash (L_Node.Element) mod Buckets'Length;
780 Bucket : Node_Access renames Buckets (J);
783 Bucket := new Node_Type'(L_Node
.Element
, Bucket
);
786 Length
:= Length
+ 1;
790 -- Start of processing for Iterate_Left
796 HT_Ops
.Free_Hash_Table
(Buckets
);
800 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
807 function Is_Empty
(Container
: Set
) return Boolean is
809 return Container
.HT
.Length
= 0;
816 function Is_In
(HT
: Hash_Table_Type
; Key
: Node_Access
) return Boolean is
818 return Element_Keys
.Find
(HT
, Key
.Element
) /= null;
825 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
826 Subset_Node
: Node_Access
;
829 if Subset
'Address = Of_Set
'Address then
833 if Subset
.Length
> Of_Set
.Length
then
837 Subset_Node
:= HT_Ops
.First
(Subset
.HT
);
838 while Subset_Node
/= null loop
839 if not Is_In
(Of_Set
.HT
, Subset_Node
) then
842 Subset_Node
:= HT_Ops
.Next
(Subset
.HT
, Subset_Node
);
854 Process
: not null access procedure (Position
: Cursor
))
856 procedure Process_Node
(Node
: Node_Access
);
857 pragma Inline
(Process_Node
);
860 new HT_Ops
.Generic_Iteration
(Process_Node
);
866 procedure Process_Node
(Node
: Node_Access
) is
868 Process
(Cursor
'(Container'Unrestricted_Access, Node));
871 B : Natural renames Container'Unrestricted_Access.HT.Busy;
873 -- Start of processing for Iterate
879 Iterate (Container.HT);
893 function Length (Container : Set) return Count_Type is
895 return Container.HT.Length;
902 procedure Move (Target : in out Set; Source : in out Set) is
904 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
911 function Next (Node : Node_Access) return Node_Access is
916 function Next (Position : Cursor) return Cursor is
918 if Position.Node = null then
922 pragma Assert (Vet (Position), "bad cursor in Next");
925 HT : Hash_Table_Type renames Position.Container.HT;
926 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
933 return Cursor'(Position
.Container
, Node
);
937 procedure Next
(Position
: in out Cursor
) is
939 Position
:= Next
(Position
);
946 function Overlap
(Left
, Right
: Set
) return Boolean is
947 Left_Node
: Node_Access
;
950 if Right
.Length
= 0 then
954 if Left
'Address = Right
'Address then
958 Left_Node
:= HT_Ops
.First
(Left
.HT
);
959 while Left_Node
/= null loop
960 if Is_In
(Right
.HT
, Left_Node
) then
963 Left_Node
:= HT_Ops
.Next
(Left
.HT
, Left_Node
);
973 procedure Query_Element
975 Process
: not null access procedure (Element
: Element_Type
))
978 if Position
.Node
= null then
979 raise Constraint_Error
with
980 "Position cursor of Query_Element equals No_Element";
983 pragma Assert
(Vet
(Position
), "bad cursor in Query_Element");
986 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
988 B
: Natural renames HT
.Busy
;
989 L
: Natural renames HT
.Lock
;
996 Process
(Position
.Node
.Element
);
1014 (Stream
: not null access Root_Stream_Type
'Class;
1015 Container
: out Set
)
1018 Read_Nodes
(Stream
, Container
.HT
);
1022 (Stream
: not null access Root_Stream_Type
'Class;
1026 raise Program_Error
with "attempt to stream set cursor";
1033 function Read_Node
(Stream
: not null access Root_Stream_Type
'Class)
1036 Node
: Node_Access
:= new Node_Type
;
1039 Element_Type
'Read (Stream
, Node
.Element
);
1052 (Container
: in out Set
;
1053 New_Item
: Element_Type
)
1055 Node
: constant Node_Access
:=
1056 Element_Keys
.Find
(Container
.HT
, New_Item
);
1060 raise Constraint_Error
with
1061 "attempt to replace element not in set";
1064 if Container
.HT
.Lock
> 0 then
1065 raise Program_Error
with
1066 "attempt to tamper with cursors (set is locked)";
1069 Node
.Element
:= New_Item
;
1072 procedure Replace_Element
1073 (Container
: in out Set
;
1075 New_Item
: Element_Type
)
1078 if Position
.Node
= null then
1079 raise Constraint_Error
with
1080 "Position cursor equals No_Element";
1083 if Position
.Container
/= Container
'Unrestricted_Access then
1084 raise Program_Error
with
1085 "Position cursor designates wrong set";
1088 pragma Assert
(Vet
(Position
), "bad cursor in Replace_Element");
1090 Replace_Element
(Container
.HT
, Position
.Node
, New_Item
);
1091 end Replace_Element
;
1093 ----------------------
1094 -- Reserve_Capacity --
1095 ----------------------
1097 procedure Reserve_Capacity
1098 (Container
: in out Set
;
1099 Capacity
: Count_Type
)
1102 HT_Ops
.Reserve_Capacity
(Container
.HT
, Capacity
);
1103 end Reserve_Capacity
;
1109 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
) is
1114 --------------------------
1115 -- Symmetric_Difference --
1116 --------------------------
1118 procedure Symmetric_Difference
1119 (Target
: in out Set
;
1123 if Target
'Address = Source
'Address then
1128 if Target
.HT
.Busy
> 0 then
1129 raise Program_Error
with
1130 "attempt to tamper with elements (set is busy)";
1134 N
: constant Count_Type
:= Target
.Length
+ Source
.Length
;
1136 if N
> HT_Ops
.Capacity
(Target
.HT
) then
1137 HT_Ops
.Reserve_Capacity
(Target
.HT
, N
);
1141 if Target
.Length
= 0 then
1142 Iterate_Source_When_Empty_Target
: declare
1143 procedure Process
(Src_Node
: Node_Access
);
1145 procedure Iterate
is
1146 new HT_Ops
.Generic_Iteration
(Process
);
1152 procedure Process
(Src_Node
: Node_Access
) is
1153 E
: Element_Type
renames Src_Node
.Element
;
1154 B
: Buckets_Type
renames Target
.HT
.Buckets
.all;
1155 J
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
1156 N
: Count_Type
renames Target
.HT
.Length
;
1159 B
(J
) := new Node_Type
'(E, B (J));
1163 -- Start of processing for Iterate_Source_When_Empty_Target
1166 Iterate (Source.HT);
1167 end Iterate_Source_When_Empty_Target;
1170 Iterate_Source : declare
1171 procedure Process (Src_Node : Node_Access);
1173 procedure Iterate is
1174 new HT_Ops.Generic_Iteration (Process);
1180 procedure Process (Src_Node : Node_Access) is
1181 E : Element_Type renames Src_Node.Element;
1182 B : Buckets_Type renames Target.HT.Buckets.all;
1183 J : constant Hash_Type := Hash (E) mod B'Length;
1184 N : Count_Type renames Target.HT.Length;
1187 if B (J) = null then
1188 B (J) := new Node_Type'(E
, null);
1191 elsif Equivalent_Elements
(E
, B
(J
).Element
) then
1193 X
: Node_Access
:= B
(J
);
1195 B
(J
) := B
(J
).Next
;
1202 Prev
: Node_Access
:= B
(J
);
1203 Curr
: Node_Access
:= Prev
.Next
;
1206 while Curr
/= null loop
1207 if Equivalent_Elements
(E
, Curr
.Element
) then
1208 Prev
.Next
:= Curr
.Next
;
1218 B
(J
) := new Node_Type
'(E, B (J));
1224 -- Start of processing for Iterate_Source
1227 Iterate (Source.HT);
1230 end Symmetric_Difference;
1232 function Symmetric_Difference (Left, Right : Set) return Set is
1233 Buckets : HT_Types.Buckets_Access;
1234 Length : Count_Type;
1237 if Left'Address = Right'Address then
1241 if Right.Length = 0 then
1245 if Left.Length = 0 then
1250 Size : constant Hash_Type :=
1251 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1253 Buckets := HT_Ops.New_Buckets (Length => Size);
1258 Iterate_Left : declare
1259 procedure Process (L_Node : Node_Access);
1261 procedure Iterate is
1262 new HT_Ops.Generic_Iteration (Process);
1268 procedure Process (L_Node : Node_Access) is
1270 if not Is_In (Right.HT, L_Node) then
1272 E : Element_Type renames L_Node.Element;
1273 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1276 Buckets (J) := new Node_Type'(E
, Buckets
(J
));
1277 Length
:= Length
+ 1;
1282 -- Start of processing for Iterate_Left
1288 HT_Ops
.Free_Hash_Table
(Buckets
);
1292 Iterate_Right
: declare
1293 procedure Process
(R_Node
: Node_Access
);
1295 procedure Iterate
is
1296 new HT_Ops
.Generic_Iteration
(Process
);
1302 procedure Process
(R_Node
: Node_Access
) is
1304 if not Is_In
(Left
.HT
, R_Node
) then
1306 E
: Element_Type
renames R_Node
.Element
;
1307 J
: constant Hash_Type
:= Hash
(E
) mod Buckets
'Length;
1310 Buckets
(J
) := new Node_Type
'(E, Buckets (J));
1311 Length := Length + 1;
1316 -- Start of processing for Iterate_Right
1322 HT_Ops.Free_Hash_Table (Buckets);
1326 return (Controlled with HT => (Buckets, Length, 0, 0));
1327 end Symmetric_Difference;
1333 function To_Set (New_Item : Element_Type) return Set is
1334 HT : Hash_Table_Type;
1338 pragma Unreferenced (Node, Inserted);
1341 Insert (HT, New_Item, Node, Inserted);
1342 return Set'(Controlled
with HT
);
1350 (Target
: in out Set
;
1353 procedure Process
(Src_Node
: Node_Access
);
1355 procedure Iterate
is
1356 new HT_Ops
.Generic_Iteration
(Process
);
1362 procedure Process
(Src_Node
: Node_Access
) is
1363 function New_Node
(Next
: Node_Access
) return Node_Access
;
1364 pragma Inline
(New_Node
);
1367 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
1373 function New_Node
(Next
: Node_Access
) return Node_Access
is
1374 Node
: constant Node_Access
:=
1375 new Node_Type
'(Src_Node.Element, Next);
1380 Tgt_Node : Node_Access;
1382 pragma Unreferenced (Tgt_Node, Success);
1384 -- Start of processing for Process
1387 Insert (Target.HT, Src_Node.Element, Tgt_Node, Success);
1390 -- Start of processing for Union
1393 if Target'Address = Source'Address then
1397 if Target.HT.Busy > 0 then
1398 raise Program_Error with
1399 "attempt to tamper with elements (set is busy)";
1403 N : constant Count_Type := Target.Length + Source.Length;
1405 if N > HT_Ops.Capacity (Target.HT) then
1406 HT_Ops.Reserve_Capacity (Target.HT, N);
1410 Iterate (Source.HT);
1413 function Union (Left, Right : Set) return Set is
1414 Buckets : HT_Types.Buckets_Access;
1415 Length : Count_Type;
1418 if Left'Address = Right'Address then
1422 if Right.Length = 0 then
1426 if Left.Length = 0 then
1431 Size : constant Hash_Type :=
1432 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1434 Buckets := HT_Ops.New_Buckets (Length => Size);
1437 Iterate_Left : declare
1438 procedure Process (L_Node : Node_Access);
1440 procedure Iterate is
1441 new HT_Ops.Generic_Iteration (Process);
1447 procedure Process (L_Node : Node_Access) is
1448 J : constant Hash_Type :=
1449 Hash (L_Node.Element) mod Buckets'Length;
1452 Buckets (J) := new Node_Type'(L_Node
.Element
, Buckets
(J
));
1455 -- Start of processing for Iterate_Left
1461 HT_Ops
.Free_Hash_Table
(Buckets
);
1465 Length
:= Left
.Length
;
1467 Iterate_Right
: declare
1468 procedure Process
(Src_Node
: Node_Access
);
1470 procedure Iterate
is
1471 new HT_Ops
.Generic_Iteration
(Process
);
1477 procedure Process
(Src_Node
: Node_Access
) is
1478 J
: constant Hash_Type
:=
1479 Hash
(Src_Node
.Element
) mod Buckets
'Length;
1481 Tgt_Node
: Node_Access
:= Buckets
(J
);
1484 while Tgt_Node
/= null loop
1485 if Equivalent_Elements
(Src_Node
.Element
, Tgt_Node
.Element
) then
1489 Tgt_Node
:= Next
(Tgt_Node
);
1492 Buckets
(J
) := new Node_Type
'(Src_Node.Element, Buckets (J));
1493 Length := Length + 1;
1496 -- Start of processing for Iterate_Right
1502 HT_Ops.Free_Hash_Table (Buckets);
1506 return (Controlled with HT => (Buckets, Length, 0, 0));
1513 function Vet (Position : Cursor) return Boolean is
1515 if Position.Node = null then
1516 return Position.Container = null;
1519 if Position.Container = null then
1523 if Position.Node.Next = Position.Node then
1528 HT : Hash_Table_Type renames Position.Container.HT;
1532 if HT.Length = 0 then
1536 if HT.Buckets = null
1537 or else HT.Buckets'Length = 0
1542 X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element));
1544 for J in 1 .. HT.Length loop
1545 if X = Position.Node then
1553 if X = X.Next then -- to prevent unnecessary looping
1569 (Stream : not null access Root_Stream_Type'Class;
1573 Write_Nodes (Stream, Container.HT);
1577 (Stream : not null access Root_Stream_Type'Class;
1581 raise Program_Error with "attempt to stream set cursor";
1588 procedure Write_Node
1589 (Stream : not null access Root_Stream_Type'Class;
1593 Element_Type'Write (Stream, Node.Element);
1596 package body Generic_Keys is
1598 -----------------------
1599 -- Local Subprograms --
1600 -----------------------
1602 function Equivalent_Key_Node
1604 Node : Node_Access) return Boolean;
1605 pragma Inline (Equivalent_Key_Node);
1607 --------------------------
1608 -- Local Instantiations --
1609 --------------------------
1612 new Hash_Tables.Generic_Keys
1613 (HT_Types => HT_Types,
1615 Set_Next => Set_Next,
1616 Key_Type => Key_Type,
1618 Equivalent_Keys => Equivalent_Key_Node);
1626 Key : Key_Type) return Boolean
1629 return Find (Container, Key) /= No_Element;
1637 (Container : in out Set;
1643 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1646 raise Constraint_Error with "attempt to delete key not in set";
1658 Key : Key_Type) return Element_Type
1660 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1664 raise Constraint_Error with "key not in map";
1667 return Node.Element;
1670 -------------------------
1671 -- Equivalent_Key_Node --
1672 -------------------------
1674 function Equivalent_Key_Node
1676 Node : Node_Access) return Boolean
1679 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1680 end Equivalent_Key_Node;
1687 (Container : in out Set;
1692 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1702 Key : Key_Type) return Cursor
1704 Node : constant Node_Access :=
1705 Key_Keys.Find (Container.HT, Key);
1712 return Cursor'(Container
'Unrestricted_Access, Node
);
1719 function Key
(Position
: Cursor
) return Key_Type
is
1721 if Position
.Node
= null then
1722 raise Constraint_Error
with
1723 "Position cursor equals No_Element";
1726 pragma Assert
(Vet
(Position
), "bad cursor in function Key");
1728 return Key
(Position
.Node
.Element
);
1736 (Container
: in out Set
;
1738 New_Item
: Element_Type
)
1740 Node
: constant Node_Access
:=
1741 Key_Keys
.Find
(Container
.HT
, Key
);
1745 raise Constraint_Error
with
1746 "attempt to replace key not in set";
1749 Replace_Element
(Container
.HT
, Node
, New_Item
);
1752 -----------------------------------
1753 -- Update_Element_Preserving_Key --
1754 -----------------------------------
1756 procedure Update_Element_Preserving_Key
1757 (Container
: in out Set
;
1759 Process
: not null access
1760 procedure (Element
: in out Element_Type
))
1762 HT
: Hash_Table_Type
renames Container
.HT
;
1766 if Position
.Node
= null then
1767 raise Constraint_Error
with
1768 "Position cursor equals No_Element";
1771 if Position
.Container
/= Container
'Unrestricted_Access then
1772 raise Program_Error
with
1773 "Position cursor designates wrong set";
1776 if HT
.Buckets
= null
1777 or else HT
.Buckets
'Length = 0
1778 or else HT
.Length
= 0
1779 or else Position
.Node
.Next
= Position
.Node
1781 raise Program_Error
with "Position cursor is bad (set is empty)";
1786 "bad cursor in Update_Element_Preserving_Key");
1788 Indx
:= HT_Ops
.Index
(HT
, Position
.Node
);
1791 E
: Element_Type
renames Position
.Node
.Element
;
1792 K
: constant Key_Type
:= Key
(E
);
1794 B
: Natural renames HT
.Busy
;
1795 L
: Natural renames HT
.Lock
;
1813 if Equivalent_Keys
(K
, Key
(E
)) then
1814 pragma Assert
(Hash
(K
) = Hash
(E
));
1819 if HT
.Buckets
(Indx
) = Position
.Node
then
1820 HT
.Buckets
(Indx
) := Position
.Node
.Next
;
1824 Prev
: Node_Access
:= HT
.Buckets
(Indx
);
1827 while Prev
.Next
/= Position
.Node
loop
1831 raise Program_Error
with
1832 "Position cursor is bad (node not found)";
1836 Prev
.Next
:= Position
.Node
.Next
;
1840 HT
.Length
:= HT
.Length
- 1;
1843 X
: Node_Access
:= Position
.Node
;
1849 raise Program_Error
with "key was modified";
1850 end Update_Element_Preserving_Key
;
1854 end Ada
.Containers
.Hashed_Sets
;