1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . --
6 -- I N D E F I N I T E _ H A S H E D _ S E T S --
10 -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- This unit has originally being developed by Matthew J Heaney. --
31 ------------------------------------------------------------------------------
33 with Ada
.Unchecked_Deallocation
;
35 with Ada
.Containers
.Hash_Tables
.Generic_Operations
;
36 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Operations
);
38 with Ada
.Containers
.Hash_Tables
.Generic_Keys
;
39 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Keys
);
41 with Ada
.Containers
.Prime_Numbers
;
43 with System
; use type System
.Address
;
45 package body Ada
.Containers
.Indefinite_Hashed_Sets
is
47 -----------------------
48 -- Local Subprograms --
49 -----------------------
51 procedure Assign
(Node
: Node_Access
; Item
: Element_Type
);
52 pragma Inline
(Assign
);
54 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
55 pragma Inline
(Copy_Node
);
57 function Equivalent_Keys
59 Node
: Node_Access
) return Boolean;
60 pragma Inline
(Equivalent_Keys
);
62 function Find_Equal_Key
63 (R_HT
: Hash_Table_Type
;
64 L_Node
: Node_Access
) return Boolean;
66 function Find_Equivalent_Key
67 (R_HT
: Hash_Table_Type
;
68 L_Node
: Node_Access
) return Boolean;
70 procedure Free
(X
: in out Node_Access
);
72 function Hash_Node
(Node
: Node_Access
) return Hash_Type
;
73 pragma Inline
(Hash_Node
);
76 (HT
: in out Hash_Table_Type
;
77 New_Item
: Element_Type
;
78 Node
: out Node_Access
;
79 Inserted
: out Boolean);
81 function Is_In
(HT
: Hash_Table_Type
; Key
: Node_Access
) return Boolean;
82 pragma Inline
(Is_In
);
84 function Next
(Node
: Node_Access
) return Node_Access
;
87 function Read_Node
(Stream
: access Root_Stream_Type
'Class)
89 pragma Inline
(Read_Node
);
91 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
);
92 pragma Inline
(Set_Next
);
94 function Vet
(Position
: Cursor
) return Boolean;
97 (Stream
: access Root_Stream_Type
'Class;
99 pragma Inline
(Write_Node
);
101 --------------------------
102 -- Local Instantiations --
103 --------------------------
105 procedure Free_Element
is
106 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
109 new Hash_Tables
.Generic_Operations
110 (HT_Types
=> HT_Types
,
111 Hash_Node
=> Hash_Node
,
113 Set_Next
=> Set_Next
,
114 Copy_Node
=> Copy_Node
,
117 package Element_Keys
is
118 new Hash_Tables
.Generic_Keys
119 (HT_Types
=> HT_Types
,
121 Set_Next
=> Set_Next
,
122 Key_Type
=> Element_Type
,
124 Equivalent_Keys
=> Equivalent_Keys
);
127 new HT_Ops
.Generic_Equal
(Find_Equal_Key
);
129 function Is_Equivalent
is
130 new HT_Ops
.Generic_Equal
(Find_Equivalent_Key
);
132 procedure Read_Nodes
is
133 new HT_Ops
.Generic_Read
(Read_Node
);
135 procedure Replace_Element
is
136 new Element_Keys
.Generic_Replace_Element
(Hash_Node
, Assign
);
138 procedure Write_Nodes
is
139 new HT_Ops
.Generic_Write
(Write_Node
);
145 function "=" (Left
, Right
: Set
) return Boolean is
147 return Is_Equal
(Left
.HT
, Right
.HT
);
154 procedure Adjust
(Container
: in out Set
) is
156 HT_Ops
.Adjust
(Container
.HT
);
163 procedure Assign
(Node
: Node_Access
; Item
: Element_Type
) is
164 X
: Element_Access
:= Node
.Element
;
166 Node
.Element
:= new Element_Type
'(Item);
174 function Capacity (Container : Set) return Count_Type is
176 return HT_Ops.Capacity (Container.HT);
183 procedure Clear (Container : in out Set) is
185 HT_Ops.Clear (Container.HT);
192 function Contains (Container : Set; Item : Element_Type) return Boolean is
194 return Find (Container, Item) /= No_Element;
201 function Copy_Node (Source : Node_Access) return Node_Access is
202 E : Element_Access := new Element_Type'(Source
.Element
.all);
204 return new Node_Type
'(Element => E, Next => null);
216 (Container : in out Set;
222 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
225 raise Constraint_Error with "attempt to delete element not in set";
232 (Container : in out Set;
233 Position : in out Cursor)
236 if Position.Node = null then
237 raise Constraint_Error with "Position cursor equals No_Element";
240 if Position.Node.Element = null then
241 raise Program_Error with "Position cursor is bad";
244 if Position.Container /= Container'Unrestricted_Access then
245 raise Program_Error with "Position cursor designates wrong set";
248 if Container.HT.Busy > 0 then
249 raise Program_Error with
250 "attempt to tamper with elements (set is busy)";
253 pragma Assert (Vet (Position), "Position cursor is bad");
255 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
257 Free (Position.Node);
258 Position.Container := null;
266 (Target : in out Set;
269 Tgt_Node : Node_Access;
272 if Target'Address = Source'Address then
277 if Source.HT.Length = 0 then
281 if Target.HT.Busy > 0 then
282 raise Program_Error with
283 "attempt to tamper with elements (set is busy)";
286 if Source.HT.Length < Target.HT.Length then
288 Src_Node : Node_Access;
291 Src_Node := HT_Ops.First (Source.HT);
292 while Src_Node /= null loop
293 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
295 if Tgt_Node /= null then
296 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
300 Src_Node := HT_Ops.Next (Source.HT, Src_Node);
305 Tgt_Node := HT_Ops.First (Target.HT);
306 while Tgt_Node /= null loop
307 if Is_In (Source.HT, Tgt_Node) then
309 X : Node_Access := Tgt_Node;
311 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
312 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
317 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
323 function Difference (Left, Right : Set) return Set is
324 Buckets : HT_Types.Buckets_Access;
328 if Left'Address = Right'Address then
332 if Left.Length = 0 then
336 if Right.Length = 0 then
341 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
343 Buckets := new Buckets_Type (0 .. Size - 1);
348 Iterate_Left : declare
349 procedure Process (L_Node : Node_Access);
352 new HT_Ops.Generic_Iteration (Process);
358 procedure Process (L_Node : Node_Access) is
360 if not Is_In (Right.HT, L_Node) then
362 Src : Element_Type renames L_Node.Element.all;
363 Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
364 Bucket : Node_Access renames Buckets (Indx);
365 Tgt : Element_Access := new Element_Type'(Src
);
367 Bucket
:= new Node_Type
'(Tgt, Bucket);
374 Length := Length + 1;
378 -- Start of processing for Iterate_Left
384 HT_Ops.Free_Hash_Table (Buckets);
388 return (Controlled with HT => (Buckets, Length, 0, 0));
395 function Element (Position : Cursor) return Element_Type is
397 if Position.Node = null then
398 raise Constraint_Error with "Position cursor of equals No_Element";
401 if Position.Node.Element = null then -- handle dangling reference
402 raise Program_Error with "Position cursor is bad";
405 pragma Assert (Vet (Position), "bad cursor in function Element");
407 return Position.Node.Element.all;
410 ---------------------
411 -- Equivalent_Sets --
412 ---------------------
414 function Equivalent_Sets (Left, Right : Set) return Boolean is
416 return Is_Equivalent (Left.HT, Right.HT);
419 -------------------------
420 -- Equivalent_Elements --
421 -------------------------
423 function Equivalent_Elements (Left, Right : Cursor)
426 if Left.Node = null then
427 raise Constraint_Error with
428 "Left cursor of Equivalent_Elements equals No_Element";
431 if Right.Node = null then
432 raise Constraint_Error with
433 "Right cursor of Equivalent_Elements equals No_Element";
436 if Left.Node.Element = null then
437 raise Program_Error with
438 "Left cursor of Equivalent_Elements is bad";
441 if Right.Node.Element = null then
442 raise Program_Error with
443 "Right cursor of Equivalent_Elements is bad";
446 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
447 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
449 return Equivalent_Elements
450 (Left.Node.Element.all,
451 Right.Node.Element.all);
452 end Equivalent_Elements;
454 function Equivalent_Elements (Left : Cursor; Right : Element_Type)
457 if Left.Node = null then
458 raise Constraint_Error with
459 "Left cursor of Equivalent_Elements equals No_Element";
462 if Left.Node.Element = null then
463 raise Program_Error with
464 "Left cursor of Equivalent_Elements is bad";
467 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
469 return Equivalent_Elements (Left.Node.Element.all, Right);
470 end Equivalent_Elements;
472 function Equivalent_Elements (Left : Element_Type; Right : Cursor)
475 if Right.Node = null then
476 raise Constraint_Error with
477 "Right cursor of Equivalent_Elements equals No_Element";
480 if Right.Node.Element = null then
481 raise Program_Error with
482 "Right cursor of Equivalent_Elements is bad";
485 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
487 return Equivalent_Elements (Left, Right.Node.Element.all);
488 end Equivalent_Elements;
490 ---------------------
491 -- Equivalent_Keys --
492 ---------------------
494 function Equivalent_Keys (Key : Element_Type; Node : Node_Access)
497 return Equivalent_Elements (Key, Node.Element.all);
505 (Container : in out Set;
510 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
518 procedure Finalize (Container : in out Set) is
520 HT_Ops.Finalize (Container.HT);
529 Item : Element_Type) return Cursor
531 Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
538 return Cursor'(Container
'Unrestricted_Access, Node
);
545 function Find_Equal_Key
546 (R_HT
: Hash_Table_Type
;
547 L_Node
: Node_Access
) return Boolean
549 R_Index
: constant Hash_Type
:=
550 Element_Keys
.Index
(R_HT
, L_Node
.Element
.all);
552 R_Node
: Node_Access
:= R_HT
.Buckets
(R_Index
);
556 if R_Node
= null then
560 if L_Node
.Element
.all = R_Node
.Element
.all then
564 R_Node
:= Next
(R_Node
);
568 -------------------------
569 -- Find_Equivalent_Key --
570 -------------------------
572 function Find_Equivalent_Key
573 (R_HT
: Hash_Table_Type
;
574 L_Node
: Node_Access
) return Boolean
576 R_Index
: constant Hash_Type
:=
577 Element_Keys
.Index
(R_HT
, L_Node
.Element
.all);
579 R_Node
: Node_Access
:= R_HT
.Buckets
(R_Index
);
583 if R_Node
= null then
587 if Equivalent_Elements
(L_Node
.Element
.all, R_Node
.Element
.all) then
591 R_Node
:= Next
(R_Node
);
593 end Find_Equivalent_Key
;
599 function First
(Container
: Set
) return Cursor
is
600 Node
: constant Node_Access
:= HT_Ops
.First
(Container
.HT
);
607 return Cursor
'(Container'Unrestricted_Access, Node);
614 procedure Free (X : in out Node_Access) is
615 procedure Deallocate is
616 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
623 X.Next := X; -- detect mischief (in Vet)
626 Free_Element (X.Element);
641 function Has_Element (Position : Cursor) return Boolean is
643 pragma Assert (Vet (Position), "bad cursor in Has_Element");
644 return Position.Node /= null;
651 function Hash_Node (Node : Node_Access) return Hash_Type is
653 return Hash (Node.Element.all);
661 (Container : in out Set;
662 New_Item : Element_Type)
670 Insert (Container, New_Item, Position, Inserted);
673 if Container.HT.Lock > 0 then
674 raise Program_Error with
675 "attempt to tamper with cursors (set is locked)";
678 X := Position.Node.Element;
680 Position.Node.Element := new Element_Type'(New_Item
);
691 (Container
: in out Set
;
692 New_Item
: Element_Type
;
693 Position
: out Cursor
;
694 Inserted
: out Boolean)
697 Insert
(Container
.HT
, New_Item
, Position
.Node
, Inserted
);
698 Position
.Container
:= Container
'Unchecked_Access;
702 (Container
: in out Set
;
703 New_Item
: Element_Type
)
709 Insert
(Container
, New_Item
, Position
, Inserted
);
712 raise Constraint_Error
with
713 "attempt to insert element already in set";
718 (HT
: in out Hash_Table_Type
;
719 New_Item
: Element_Type
;
720 Node
: out Node_Access
;
721 Inserted
: out Boolean)
723 function New_Node
(Next
: Node_Access
) return Node_Access
;
724 pragma Inline
(New_Node
);
726 procedure Local_Insert
is
727 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
733 function New_Node
(Next
: Node_Access
) return Node_Access
is
734 Element
: Element_Access
:= new Element_Type
'(New_Item);
737 return new Node_Type'(Element
, Next
);
740 Free_Element
(Element
);
744 -- Start of processing for Insert
747 if HT_Ops
.Capacity
(HT
) = 0 then
748 HT_Ops
.Reserve_Capacity
(HT
, 1);
751 Local_Insert
(HT
, New_Item
, Node
, Inserted
);
754 and then HT
.Length
> HT_Ops
.Capacity
(HT
)
756 HT_Ops
.Reserve_Capacity
(HT
, HT
.Length
);
764 procedure Intersection
765 (Target
: in out Set
;
768 Tgt_Node
: Node_Access
;
771 if Target
'Address = Source
'Address then
775 if Source
.Length
= 0 then
780 if Target
.HT
.Busy
> 0 then
781 raise Program_Error
with
782 "attempt to tamper with elements (set is busy)";
785 Tgt_Node
:= HT_Ops
.First
(Target
.HT
);
786 while Tgt_Node
/= null loop
787 if Is_In
(Source
.HT
, Tgt_Node
) then
788 Tgt_Node
:= HT_Ops
.Next
(Target
.HT
, Tgt_Node
);
792 X
: Node_Access
:= Tgt_Node
;
794 Tgt_Node
:= HT_Ops
.Next
(Target
.HT
, Tgt_Node
);
795 HT_Ops
.Delete_Node_Sans_Free
(Target
.HT
, X
);
802 function Intersection
(Left
, Right
: Set
) return Set
is
803 Buckets
: HT_Types
.Buckets_Access
;
807 if Left
'Address = Right
'Address then
811 Length
:= Count_Type
'Min (Left
.Length
, Right
.Length
);
818 Size
: constant Hash_Type
:= Prime_Numbers
.To_Prime
(Length
);
820 Buckets
:= new Buckets_Type
(0 .. Size
- 1);
825 Iterate_Left
: declare
826 procedure Process
(L_Node
: Node_Access
);
829 new HT_Ops
.Generic_Iteration
(Process
);
835 procedure Process
(L_Node
: Node_Access
) is
837 if Is_In
(Right
.HT
, L_Node
) then
839 Src
: Element_Type
renames L_Node
.Element
.all;
841 Indx
: constant Hash_Type
:= Hash
(Src
) mod Buckets
'Length;
843 Bucket
: Node_Access
renames Buckets
(Indx
);
845 Tgt
: Element_Access
:= new Element_Type
'(Src);
848 Bucket := new Node_Type'(Tgt
, Bucket
);
855 Length
:= Length
+ 1;
859 -- Start of processing for Iterate_Left
865 HT_Ops
.Free_Hash_Table
(Buckets
);
869 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
876 function Is_Empty
(Container
: Set
) return Boolean is
878 return Container
.HT
.Length
= 0;
885 function Is_In
(HT
: Hash_Table_Type
; Key
: Node_Access
) return Boolean is
887 return Element_Keys
.Find
(HT
, Key
.Element
.all) /= null;
896 Of_Set
: Set
) return Boolean
898 Subset_Node
: Node_Access
;
901 if Subset
'Address = Of_Set
'Address then
905 if Subset
.Length
> Of_Set
.Length
then
909 Subset_Node
:= HT_Ops
.First
(Subset
.HT
);
910 while Subset_Node
/= null loop
911 if not Is_In
(Of_Set
.HT
, Subset_Node
) then
915 Subset_Node
:= HT_Ops
.Next
(Subset
.HT
, Subset_Node
);
927 Process
: not null access procedure (Position
: Cursor
))
929 procedure Process_Node
(Node
: Node_Access
);
930 pragma Inline
(Process_Node
);
933 new HT_Ops
.Generic_Iteration
(Process_Node
);
939 procedure Process_Node
(Node
: Node_Access
) is
941 Process
(Cursor
'(Container'Unrestricted_Access, Node));
944 B : Natural renames Container'Unrestricted_Access.HT.Busy;
946 -- Start of processing for Iterate
952 Iterate (Container.HT);
966 function Length (Container : Set) return Count_Type is
968 return Container.HT.Length;
975 procedure Move (Target : in out Set; Source : in out Set) is
977 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
984 function Next (Node : Node_Access) return Node_Access is
989 function Next (Position : Cursor) return Cursor is
991 if Position.Node = null then
995 if Position.Node.Element = null then
996 raise Program_Error with "bad cursor in Next";
999 pragma Assert (Vet (Position), "bad cursor in Next");
1002 HT : Hash_Table_Type renames Position.Container.HT;
1003 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
1010 return Cursor'(Position
.Container
, Node
);
1014 procedure Next
(Position
: in out Cursor
) is
1016 Position
:= Next
(Position
);
1023 function Overlap
(Left
, Right
: Set
) return Boolean is
1024 Left_Node
: Node_Access
;
1027 if Right
.Length
= 0 then
1031 if Left
'Address = Right
'Address then
1035 Left_Node
:= HT_Ops
.First
(Left
.HT
);
1036 while Left_Node
/= null loop
1037 if Is_In
(Right
.HT
, Left_Node
) then
1041 Left_Node
:= HT_Ops
.Next
(Left
.HT
, Left_Node
);
1051 procedure Query_Element
1053 Process
: not null access procedure (Element
: Element_Type
))
1056 if Position
.Node
= null then
1057 raise Constraint_Error
with
1058 "Position cursor of Query_Element equals No_Element";
1061 if Position
.Node
.Element
= null then
1062 raise Program_Error
with "bad cursor in Query_Element";
1065 pragma Assert
(Vet
(Position
), "bad cursor in Query_Element");
1068 HT
: Hash_Table_Type
renames
1069 Position
.Container
'Unrestricted_Access.all.HT
;
1071 B
: Natural renames HT
.Busy
;
1072 L
: Natural renames HT
.Lock
;
1079 Process
(Position
.Node
.Element
.all);
1097 (Stream
: access Root_Stream_Type
'Class;
1098 Container
: out Set
)
1101 Read_Nodes
(Stream
, Container
.HT
);
1105 (Stream
: access Root_Stream_Type
'Class;
1109 raise Program_Error
with "attempt to stream set cursor";
1117 (Stream
: access Root_Stream_Type
'Class) return Node_Access
1119 X
: Element_Access
:= new Element_Type
'(Element_Type'Input (Stream));
1122 return new Node_Type'(X
, null);
1134 (Container
: in out Set
;
1135 New_Item
: Element_Type
)
1137 Node
: constant Node_Access
:=
1138 Element_Keys
.Find
(Container
.HT
, New_Item
);
1144 raise Constraint_Error
with
1145 "attempt to replace element not in set";
1148 if Container
.HT
.Lock
> 0 then
1149 raise Program_Error
with
1150 "attempt to tamper with cursors (set is locked)";
1155 Node
.Element
:= new Element_Type
'(New_Item);
1160 ---------------------
1161 -- Replace_Element --
1162 ---------------------
1164 procedure Replace_Element
1165 (Container : in out Set;
1167 New_Item : Element_Type)
1170 if Position.Node = null then
1171 raise Constraint_Error with "Position cursor equals No_Element";
1174 if Position.Node.Element = null then
1175 raise Program_Error with "bad cursor in Replace_Element";
1178 if Position.Container /= Container'Unrestricted_Access then
1179 raise Program_Error with
1180 "Position cursor designates wrong set";
1183 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1185 Replace_Element (Container.HT, Position.Node, New_Item);
1186 end Replace_Element;
1188 ----------------------
1189 -- Reserve_Capacity --
1190 ----------------------
1192 procedure Reserve_Capacity
1193 (Container : in out Set;
1194 Capacity : Count_Type)
1197 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1198 end Reserve_Capacity;
1204 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1209 --------------------------
1210 -- Symmetric_Difference --
1211 --------------------------
1213 procedure Symmetric_Difference
1214 (Target : in out Set;
1218 if Target'Address = Source'Address then
1223 if Target.HT.Busy > 0 then
1224 raise Program_Error with
1225 "attempt to tamper with elements (set is busy)";
1229 N : constant Count_Type := Target.Length + Source.Length;
1231 if N > HT_Ops.Capacity (Target.HT) then
1232 HT_Ops.Reserve_Capacity (Target.HT, N);
1236 if Target.Length = 0 then
1237 Iterate_Source_When_Empty_Target : declare
1238 procedure Process (Src_Node : Node_Access);
1240 procedure Iterate is
1241 new HT_Ops.Generic_Iteration (Process);
1247 procedure Process (Src_Node : Node_Access) is
1248 E : Element_Type renames Src_Node.Element.all;
1249 B : Buckets_Type renames Target.HT.Buckets.all;
1250 J : constant Hash_Type := Hash (E) mod B'Length;
1251 N : Count_Type renames Target.HT.Length;
1255 X : Element_Access := new Element_Type'(E
);
1257 B
(J
) := new Node_Type
'(X, B (J));
1267 -- Start of processing for Iterate_Source_When_Empty_Target
1270 Iterate (Source.HT);
1271 end Iterate_Source_When_Empty_Target;
1274 Iterate_Source : declare
1275 procedure Process (Src_Node : Node_Access);
1277 procedure Iterate is
1278 new HT_Ops.Generic_Iteration (Process);
1284 procedure Process (Src_Node : Node_Access) is
1285 E : Element_Type renames Src_Node.Element.all;
1286 B : Buckets_Type renames Target.HT.Buckets.all;
1287 J : constant Hash_Type := Hash (E) mod B'Length;
1288 N : Count_Type renames Target.HT.Length;
1291 if B (J) = null then
1293 X : Element_Access := new Element_Type'(E
);
1295 B
(J
) := new Node_Type
'(X, null);
1304 elsif Equivalent_Elements (E, B (J).Element.all) then
1306 X : Node_Access := B (J);
1308 B (J) := B (J).Next;
1315 Prev : Node_Access := B (J);
1316 Curr : Node_Access := Prev.Next;
1319 while Curr /= null loop
1320 if Equivalent_Elements (E, Curr.Element.all) then
1321 Prev.Next := Curr.Next;
1332 X : Element_Access := new Element_Type'(E
);
1334 B
(J
) := new Node_Type
'(X, B (J));
1346 -- Start of processing for Iterate_Source
1349 Iterate (Source.HT);
1352 end Symmetric_Difference;
1354 function Symmetric_Difference (Left, Right : Set) return Set is
1355 Buckets : HT_Types.Buckets_Access;
1356 Length : Count_Type;
1359 if Left'Address = Right'Address then
1363 if Right.Length = 0 then
1367 if Left.Length = 0 then
1372 Size : constant Hash_Type :=
1373 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1375 Buckets := new Buckets_Type (0 .. Size - 1);
1380 Iterate_Left : declare
1381 procedure Process (L_Node : Node_Access);
1383 procedure Iterate is
1384 new HT_Ops.Generic_Iteration (Process);
1390 procedure Process (L_Node : Node_Access) is
1392 if not Is_In (Right.HT, L_Node) then
1394 E : Element_Type renames L_Node.Element.all;
1395 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1399 X : Element_Access := new Element_Type'(E
);
1401 Buckets
(J
) := new Node_Type
'(X, Buckets (J));
1408 Length := Length + 1;
1413 -- Start of processing for Iterate_Left
1419 HT_Ops.Free_Hash_Table (Buckets);
1423 Iterate_Right : declare
1424 procedure Process (R_Node : Node_Access);
1426 procedure Iterate is
1427 new HT_Ops.Generic_Iteration (Process);
1433 procedure Process (R_Node : Node_Access) is
1435 if not Is_In (Left.HT, R_Node) then
1437 E : Element_Type renames R_Node.Element.all;
1438 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1442 X : Element_Access := new Element_Type'(E
);
1444 Buckets
(J
) := new Node_Type
'(X, Buckets (J));
1451 Length := Length + 1;
1456 -- Start of processing for Iterate_Right
1462 HT_Ops.Free_Hash_Table (Buckets);
1466 return (Controlled with HT => (Buckets, Length, 0, 0));
1467 end Symmetric_Difference;
1473 function To_Set (New_Item : Element_Type) return Set is
1474 HT : Hash_Table_Type;
1479 Insert (HT, New_Item, Node, Inserted);
1480 return Set'(Controlled
with HT
);
1488 (Target
: in out Set
;
1491 procedure Process
(Src_Node
: Node_Access
);
1493 procedure Iterate
is
1494 new HT_Ops
.Generic_Iteration
(Process
);
1500 procedure Process
(Src_Node
: Node_Access
) is
1501 Src
: Element_Type
renames Src_Node
.Element
.all;
1503 function New_Node
(Next
: Node_Access
) return Node_Access
;
1504 pragma Inline
(New_Node
);
1507 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
1513 function New_Node
(Next
: Node_Access
) return Node_Access
is
1514 Tgt
: Element_Access
:= new Element_Type
'(Src);
1517 return new Node_Type'(Tgt
, Next
);
1524 Tgt_Node
: Node_Access
;
1527 -- Start of processing for Process
1530 Insert
(Target
.HT
, Src
, Tgt_Node
, Success
);
1533 -- Start of processing for Union
1536 if Target
'Address = Source
'Address then
1540 if Target
.HT
.Busy
> 0 then
1541 raise Program_Error
with
1542 "attempt to tamper with elements (set is busy)";
1546 N
: constant Count_Type
:= Target
.Length
+ Source
.Length
;
1548 if N
> HT_Ops
.Capacity
(Target
.HT
) then
1549 HT_Ops
.Reserve_Capacity
(Target
.HT
, N
);
1553 Iterate
(Source
.HT
);
1556 function Union
(Left
, Right
: Set
) return Set
is
1557 Buckets
: HT_Types
.Buckets_Access
;
1558 Length
: Count_Type
;
1561 if Left
'Address = Right
'Address then
1565 if Right
.Length
= 0 then
1569 if Left
.Length
= 0 then
1574 Size
: constant Hash_Type
:=
1575 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1577 Buckets
:= new Buckets_Type
(0 .. Size
- 1);
1580 Iterate_Left
: declare
1581 procedure Process
(L_Node
: Node_Access
);
1583 procedure Iterate
is
1584 new HT_Ops
.Generic_Iteration
(Process
);
1590 procedure Process
(L_Node
: Node_Access
) is
1591 Src
: Element_Type
renames L_Node
.Element
.all;
1593 J
: constant Hash_Type
:= Hash
(Src
) mod Buckets
'Length;
1595 Bucket
: Node_Access
renames Buckets
(J
);
1597 Tgt
: Element_Access
:= new Element_Type
'(Src);
1600 Bucket := new Node_Type'(Tgt
, Bucket
);
1607 -- Start of processing for Process
1613 HT_Ops
.Free_Hash_Table
(Buckets
);
1617 Length
:= Left
.Length
;
1619 Iterate_Right
: declare
1620 procedure Process
(Src_Node
: Node_Access
);
1622 procedure Iterate
is
1623 new HT_Ops
.Generic_Iteration
(Process
);
1629 procedure Process
(Src_Node
: Node_Access
) is
1630 Src
: Element_Type
renames Src_Node
.Element
.all;
1631 Idx
: constant Hash_Type
:= Hash
(Src
) mod Buckets
'Length;
1633 Tgt_Node
: Node_Access
:= Buckets
(Idx
);
1636 while Tgt_Node
/= null loop
1637 if Equivalent_Elements
(Src
, Tgt_Node
.Element
.all) then
1640 Tgt_Node
:= Next
(Tgt_Node
);
1644 Tgt
: Element_Access
:= new Element_Type
'(Src);
1646 Buckets (Idx) := new Node_Type'(Tgt
, Buckets
(Idx
));
1653 Length
:= Length
+ 1;
1656 -- Start of processing for Iterate_Right
1662 HT_Ops
.Free_Hash_Table
(Buckets
);
1666 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
1673 function Vet
(Position
: Cursor
) return Boolean is
1675 if Position
.Node
= null then
1676 return Position
.Container
= null;
1679 if Position
.Container
= null then
1683 if Position
.Node
.Next
= Position
.Node
then
1687 if Position
.Node
.Element
= null then
1692 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
1696 if HT
.Length
= 0 then
1700 if HT
.Buckets
= null
1701 or else HT
.Buckets
'Length = 0
1706 X
:= HT
.Buckets
(Element_Keys
.Index
(HT
, Position
.Node
.Element
.all));
1708 for J
in 1 .. HT
.Length
loop
1709 if X
= Position
.Node
then
1717 if X
= X
.Next
then -- to prevent unnecessary looping
1733 (Stream
: access Root_Stream_Type
'Class;
1737 Write_Nodes
(Stream
, Container
.HT
);
1741 (Stream
: access Root_Stream_Type
'Class;
1745 raise Program_Error
with "attempt to stream set cursor";
1752 procedure Write_Node
1753 (Stream
: access Root_Stream_Type
'Class;
1757 Element_Type
'Output (Stream
, Node
.Element
.all);
1760 package body Generic_Keys
is
1762 -----------------------
1763 -- Local Subprograms --
1764 -----------------------
1766 function Equivalent_Key_Node
1768 Node
: Node_Access
) return Boolean;
1769 pragma Inline
(Equivalent_Key_Node
);
1771 --------------------------
1772 -- Local Instantiations --
1773 --------------------------
1776 new Hash_Tables
.Generic_Keys
1777 (HT_Types
=> HT_Types
,
1779 Set_Next
=> Set_Next
,
1780 Key_Type
=> Key_Type
,
1782 Equivalent_Keys
=> Equivalent_Key_Node
);
1790 Key
: Key_Type
) return Boolean
1793 return Find
(Container
, Key
) /= No_Element
;
1801 (Container
: in out Set
;
1807 Key_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Key
, X
);
1810 raise Constraint_Error
with "key not in map";
1822 Key
: Key_Type
) return Element_Type
1824 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.HT
, Key
);
1828 raise Constraint_Error
with "key not in map";
1831 return Node
.Element
.all;
1834 -------------------------
1835 -- Equivalent_Key_Node --
1836 -------------------------
1838 function Equivalent_Key_Node
1840 Node
: Node_Access
) return Boolean is
1842 return Equivalent_Keys
(Key
, Generic_Keys
.Key
(Node
.Element
.all));
1843 end Equivalent_Key_Node
;
1850 (Container
: in out Set
;
1855 Key_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Key
, X
);
1865 Key
: Key_Type
) return Cursor
1867 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.HT
, Key
);
1874 return Cursor
'(Container'Unrestricted_Access, Node);
1881 function Key (Position : Cursor) return Key_Type is
1883 if Position.Node = null then
1884 raise Constraint_Error with
1885 "Position cursor equals No_Element";
1888 if Position.Node.Element = null then
1889 raise Program_Error with "Position cursor is bad";
1892 pragma Assert (Vet (Position), "bad cursor in function Key");
1894 return Key (Position.Node.Element.all);
1902 (Container : in out Set;
1904 New_Item : Element_Type)
1906 Node : constant Node_Access :=
1907 Key_Keys.Find (Container.HT, Key);
1911 raise Constraint_Error with
1912 "attempt to replace key not in set";
1915 Replace_Element (Container.HT, Node, New_Item);
1918 procedure Update_Element_Preserving_Key
1919 (Container : in out Set;
1921 Process : not null access
1922 procedure (Element : in out Element_Type))
1924 HT : Hash_Table_Type renames Container.HT;
1928 if Position.Node = null then
1929 raise Constraint_Error with
1930 "Position cursor equals No_Element";
1933 if Position.Node.Element = null
1934 or else Position.Node.Next = Position.Node
1936 raise Program_Error with "Position cursor is bad";
1939 if Position.Container /= Container'Unrestricted_Access then
1940 raise Program_Error with
1941 "Position cursor designates wrong set";
1944 if HT.Buckets = null
1945 or else HT.Buckets'Length = 0
1946 or else HT.Length = 0
1948 raise Program_Error with "Position cursor is bad (set is empty)";
1953 "bad cursor in Update_Element_Preserving_Key");
1955 Indx := HT_Ops.Index (HT, Position.Node);
1958 E : Element_Type renames Position.Node.Element.all;
1959 K : constant Key_Type := Key (E);
1961 B : Natural renames HT.Busy;
1962 L : Natural renames HT.Lock;
1980 if Equivalent_Keys (K, Key (E)) then
1981 pragma Assert (Hash (K) = Hash (E));
1986 if HT.Buckets (Indx) = Position.Node then
1987 HT.Buckets (Indx) := Position.Node.Next;
1991 Prev : Node_Access := HT.Buckets (Indx);
1994 while Prev.Next /= Position.Node loop
1998 raise Program_Error with
1999 "Position cursor is bad (node not found)";
2003 Prev.Next := Position.Node.Next;
2007 HT.Length := HT.Length - 1;
2010 X : Node_Access := Position.Node;
2016 raise Program_Error with "key was modified";
2017 end Update_Element_Preserving_Key;
2021 end Ada.Containers.Indefinite_Hashed_Sets;