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-2005 Free Software Foundation, Inc. --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the contents of the part following the private keyword. --
15 -- GNAT is free software; you can redistribute it and/or modify it under --
16 -- terms of the GNU General Public License as published by the Free Soft- --
17 -- ware Foundation; either version 2, or (at your option) any later ver- --
18 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
21 -- for more details. You should have received a copy of the GNU General --
22 -- Public License distributed with GNAT; see file COPYING. If not, write --
23 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
24 -- Boston, MA 02110-1301, USA. --
26 -- As a special exception, if other files instantiate generics from this --
27 -- unit, or you link this unit with other files to produce an executable, --
28 -- this unit does not by itself cause the resulting executable to be --
29 -- covered by the GNU General Public License. This exception does not --
30 -- however invalidate any other reasons why the executable file might be --
31 -- covered by the GNU Public License. --
33 -- This unit has originally being developed by Matthew J Heaney. --
34 ------------------------------------------------------------------------------
36 with Ada
.Unchecked_Deallocation
;
38 with Ada
.Containers
.Hash_Tables
.Generic_Operations
;
39 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Operations
);
41 with Ada
.Containers
.Hash_Tables
.Generic_Keys
;
42 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Keys
);
44 with Ada
.Containers
.Prime_Numbers
;
46 with System
; use type System
.Address
;
48 package body Ada
.Containers
.Hashed_Sets
is
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
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
: Hash_Table_Type
;
77 Key
: Node_Access
) return Boolean;
78 pragma Inline
(Is_In
);
80 function Next
(Node
: Node_Access
) return Node_Access
;
83 function Read_Node
(Stream
: access Root_Stream_Type
'Class)
85 pragma Inline
(Read_Node
);
87 procedure Replace_Element
88 (HT
: in out Hash_Table_Type
;
90 New_Item
: Element_Type
);
92 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
);
93 pragma Inline
(Set_Next
);
95 function Vet
(Position
: Cursor
) return Boolean;
98 (Stream
: 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 Write_Nodes
is
134 new HT_Ops
.Generic_Write
(Write_Node
);
140 function "=" (Left
, Right
: Set
) return Boolean is
142 return Is_Equal
(Left
.HT
, Right
.HT
);
149 procedure Adjust
(Container
: in out Set
) is
151 HT_Ops
.Adjust
(Container
.HT
);
158 function Capacity
(Container
: Set
) return Count_Type
is
160 return HT_Ops
.Capacity
(Container
.HT
);
167 procedure Clear
(Container
: in out Set
) is
169 HT_Ops
.Clear
(Container
.HT
);
176 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean is
178 return Find
(Container
, Item
) /= No_Element
;
185 function Copy_Node
(Source
: Node_Access
) return Node_Access
is
187 return new Node_Type
'(Element => Source.Element, Next => null);
195 (Container : in out Set;
201 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
204 raise Constraint_Error;
211 (Container : in out Set;
212 Position : in out Cursor)
215 pragma Assert (Vet (Position), "bad cursor in Delete");
217 if Position.Node = null then
218 raise Constraint_Error;
221 if Position.Container /= Container'Unrestricted_Access then
225 if Container.HT.Busy > 0 then
229 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
231 Free (Position.Node);
232 Position.Container := null;
240 (Target : in out Set;
243 Tgt_Node : Node_Access;
246 if Target'Address = Source'Address then
251 if Source.Length = 0 then
255 if Target.HT.Busy > 0 then
259 -- TODO: This can be written in terms of a loop instead as
260 -- active-iterator style, sort of like a passive iterator.
262 Tgt_Node := HT_Ops.First (Target.HT);
263 while Tgt_Node /= null loop
264 if Is_In (Source.HT, Tgt_Node) then
266 X : Node_Access := Tgt_Node;
268 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
269 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
274 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
279 function Difference (Left, Right : Set) return Set is
280 Buckets : HT_Types.Buckets_Access;
284 if Left'Address = Right'Address then
288 if Left.Length = 0 then
292 if Right.Length = 0 then
297 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
299 Buckets := new Buckets_Type (0 .. Size - 1);
304 Iterate_Left : declare
305 procedure Process (L_Node : Node_Access);
308 new HT_Ops.Generic_Iteration (Process);
314 procedure Process (L_Node : Node_Access) is
316 if not Is_In (Right.HT, L_Node) then
318 J : constant Hash_Type :=
319 Hash (L_Node.Element) mod Buckets'Length;
321 Bucket : Node_Access renames Buckets (J);
324 Bucket := new Node_Type'(L_Node
.Element
, Bucket
);
327 Length
:= Length
+ 1;
331 -- Start of processing for Iterate_Left
337 HT_Ops
.Free_Hash_Table
(Buckets
);
341 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
348 function Element
(Position
: Cursor
) return Element_Type
is
350 pragma Assert
(Vet
(Position
), "bad cursor in function Element");
352 if Position
.Node
= null then
353 raise Constraint_Error
;
356 return Position
.Node
.Element
;
359 ---------------------
360 -- Equivalent_Sets --
361 ---------------------
363 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
365 return Is_Equivalent
(Left
.HT
, Right
.HT
);
368 -------------------------
369 -- Equivalent_Elements --
370 -------------------------
372 function Equivalent_Elements
(Left
, Right
: Cursor
)
375 pragma Assert
(Vet
(Left
), "bad Left cursor in Equivalent_Keys");
376 pragma Assert
(Vet
(Right
), "bad Right cursor in Equivalent_Keys");
379 or else Right
.Node
= null
381 raise Constraint_Error
;
384 return Equivalent_Elements
(Left
.Node
.Element
, Right
.Node
.Element
);
385 end Equivalent_Elements
;
387 function Equivalent_Elements
(Left
: Cursor
; Right
: Element_Type
)
390 pragma Assert
(Vet
(Left
), "bad Left cursor in Equivalent_Keys");
392 if Left
.Node
= null then
393 raise Constraint_Error
;
396 return Equivalent_Elements
(Left
.Node
.Element
, Right
);
397 end Equivalent_Elements
;
399 function Equivalent_Elements
(Left
: Element_Type
; Right
: Cursor
)
402 pragma Assert
(Vet
(Right
), "bad Right cursor in Equivalent_Keys");
404 if Right
.Node
= null then
405 raise Constraint_Error
;
408 return Equivalent_Elements
(Left
, Right
.Node
.Element
);
409 end Equivalent_Elements
;
411 ---------------------
412 -- Equivalent_Keys --
413 ---------------------
415 function Equivalent_Keys
(Key
: Element_Type
; Node
: Node_Access
)
418 return Equivalent_Elements
(Key
, Node
.Element
);
426 (Container
: in out Set
;
431 Element_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Item
, X
);
439 procedure Finalize
(Container
: in out Set
) is
441 HT_Ops
.Finalize
(Container
.HT
);
450 Item
: Element_Type
) return Cursor
452 Node
: constant Node_Access
:= Element_Keys
.Find
(Container
.HT
, Item
);
459 return Cursor
'(Container'Unrestricted_Access, Node);
466 function Find_Equal_Key
467 (R_HT : Hash_Table_Type;
468 L_Node : Node_Access) return Boolean
470 R_Index : constant Hash_Type :=
471 Element_Keys.Index (R_HT, L_Node.Element);
473 R_Node : Node_Access := R_HT.Buckets (R_Index);
477 if R_Node = null then
481 if L_Node.Element = R_Node.Element then
485 R_Node := Next (R_Node);
489 -------------------------
490 -- Find_Equivalent_Key --
491 -------------------------
493 function Find_Equivalent_Key
494 (R_HT : Hash_Table_Type;
495 L_Node : Node_Access) return Boolean
497 R_Index : constant Hash_Type :=
498 Element_Keys.Index (R_HT, L_Node.Element);
500 R_Node : Node_Access := R_HT.Buckets (R_Index);
504 if R_Node = null then
508 if Equivalent_Elements (L_Node.Element, R_Node.Element) then
512 R_Node := Next (R_Node);
514 end Find_Equivalent_Key;
520 function First (Container : Set) return Cursor is
521 Node : constant Node_Access := HT_Ops.First (Container.HT);
528 return Cursor'(Container
'Unrestricted_Access, Node
);
535 procedure Free
(X
: in out Node_Access
) is
536 procedure Deallocate
is
537 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
541 X
.Next
:= X
; -- detect mischief (in Vet)
550 function Has_Element
(Position
: Cursor
) return Boolean is
552 pragma Assert
(Vet
(Position
), "bad cursor in Has_Element");
553 return Position
.Node
/= null;
560 function Hash_Node
(Node
: Node_Access
) return Hash_Type
is
562 return Hash
(Node
.Element
);
570 (Container
: in out Set
;
571 New_Item
: Element_Type
)
577 Insert
(Container
, New_Item
, Position
, Inserted
);
580 if Container
.HT
.Lock
> 0 then
584 Position
.Node
.Element
:= New_Item
;
593 (Container
: in out Set
;
594 New_Item
: Element_Type
;
595 Position
: out Cursor
;
596 Inserted
: out Boolean)
598 function New_Node
(Next
: Node_Access
) return Node_Access
;
599 pragma Inline
(New_Node
);
601 procedure Local_Insert
is
602 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
608 function New_Node
(Next
: Node_Access
) return Node_Access
is
609 Node
: constant Node_Access
:= new Node_Type
'(New_Item, Next);
614 HT : Hash_Table_Type renames Container.HT;
616 -- Start of processing for Insert
619 if HT_Ops.Capacity (HT) = 0 then
620 HT_Ops.Reserve_Capacity (HT, 1);
623 Local_Insert (HT, New_Item, Position.Node, Inserted);
626 and then HT.Length > HT_Ops.Capacity (HT)
628 HT_Ops.Reserve_Capacity (HT, HT.Length);
631 Position.Container := Container'Unchecked_Access;
635 (Container : in out Set;
636 New_Item : Element_Type)
642 Insert (Container, New_Item, Position, Inserted);
645 raise Constraint_Error;
653 procedure Intersection
654 (Target : in out Set;
657 Tgt_Node : Node_Access;
660 if Target'Address = Source'Address then
664 if Source.Length = 0 then
669 if Target.HT.Busy > 0 then
673 -- TODO: optimize this to use an explicit
674 -- loop instead of an active iterator
675 -- (similar to how a passive iterator is
678 -- Another possibility is to test which
679 -- set is smaller, and iterate over the
682 Tgt_Node := HT_Ops.First (Target.HT);
683 while Tgt_Node /= null loop
684 if Is_In (Source.HT, Tgt_Node) then
685 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
689 X : Node_Access := Tgt_Node;
691 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
692 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
699 function Intersection (Left, Right : Set) return Set is
700 Buckets : HT_Types.Buckets_Access;
704 if Left'Address = Right'Address then
708 Length := Count_Type'Min (Left.Length, Right.Length);
715 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
717 Buckets := new Buckets_Type (0 .. Size - 1);
722 Iterate_Left : declare
723 procedure Process (L_Node : Node_Access);
726 new HT_Ops.Generic_Iteration (Process);
732 procedure Process (L_Node : Node_Access) is
734 if Is_In (Right.HT, L_Node) then
736 J : constant Hash_Type :=
737 Hash (L_Node.Element) mod Buckets'Length;
739 Bucket : Node_Access renames Buckets (J);
742 Bucket := new Node_Type'(L_Node
.Element
, Bucket
);
745 Length
:= Length
+ 1;
749 -- Start of processing for Iterate_Left
755 HT_Ops
.Free_Hash_Table
(Buckets
);
759 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
766 function Is_Empty
(Container
: Set
) return Boolean is
768 return Container
.HT
.Length
= 0;
775 function Is_In
(HT
: Hash_Table_Type
; Key
: Node_Access
) return Boolean is
777 return Element_Keys
.Find
(HT
, Key
.Element
) /= null;
784 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
785 Subset_Node
: Node_Access
;
788 if Subset
'Address = Of_Set
'Address then
792 if Subset
.Length
> Of_Set
.Length
then
796 -- TODO: rewrite this to loop in the
797 -- style of a passive iterator.
799 Subset_Node
:= HT_Ops
.First
(Subset
.HT
);
800 while Subset_Node
/= null loop
801 if not Is_In
(Of_Set
.HT
, Subset_Node
) then
804 Subset_Node
:= HT_Ops
.Next
(Subset
.HT
, Subset_Node
);
816 Process
: not null access procedure (Position
: Cursor
))
818 procedure Process_Node
(Node
: Node_Access
);
819 pragma Inline
(Process_Node
);
822 new HT_Ops
.Generic_Iteration
(Process_Node
);
828 procedure Process_Node
(Node
: Node_Access
) is
830 Process
(Cursor
'(Container'Unrestricted_Access, Node));
833 -- Start of processing for Iterate
836 -- TODO: resolve whether HT_Ops.Generic_Iteration should
837 -- manipulate busy bit.
839 Iterate (Container.HT);
846 function Length (Container : Set) return Count_Type is
848 return Container.HT.Length;
855 procedure Move (Target : in out Set; Source : in out Set) is
857 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
864 function Next (Node : Node_Access) return Node_Access is
869 function Next (Position : Cursor) return Cursor is
871 pragma Assert (Vet (Position), "bad cursor in function Next");
873 if Position.Node = null then
878 HT : Hash_Table_Type renames Position.Container.HT;
879 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
886 return Cursor'(Position
.Container
, Node
);
890 procedure Next
(Position
: in out Cursor
) is
892 Position
:= Next
(Position
);
899 function Overlap
(Left
, Right
: Set
) return Boolean is
900 Left_Node
: Node_Access
;
903 if Right
.Length
= 0 then
907 if Left
'Address = Right
'Address then
911 Left_Node
:= HT_Ops
.First
(Left
.HT
);
912 while Left_Node
/= null loop
913 if Is_In
(Right
.HT
, Left_Node
) then
916 Left_Node
:= HT_Ops
.Next
(Left
.HT
, Left_Node
);
926 procedure Query_Element
928 Process
: not null access procedure (Element
: Element_Type
))
931 pragma Assert
(Vet
(Position
), "bad cursor in Query_Element");
933 if Position
.Node
= null then
934 raise Constraint_Error
;
938 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
940 B
: Natural renames HT
.Busy
;
941 L
: Natural renames HT
.Lock
;
948 Process
(Position
.Node
.Element
);
966 (Stream
: access Root_Stream_Type
'Class;
970 Read_Nodes
(Stream
, Container
.HT
);
977 function Read_Node
(Stream
: access Root_Stream_Type
'Class)
980 Node
: Node_Access
:= new Node_Type
;
983 Element_Type
'Read (Stream
, Node
.Element
);
996 (Container
: in out Set
;
997 New_Item
: Element_Type
)
999 Node
: constant Node_Access
:=
1000 Element_Keys
.Find
(Container
.HT
, New_Item
);
1004 raise Constraint_Error
;
1007 if Container
.HT
.Lock
> 0 then
1008 raise Program_Error
;
1011 Node
.Element
:= New_Item
;
1014 ---------------------
1015 -- Replace_Element --
1016 ---------------------
1018 procedure Replace_Element
1019 (HT
: in out Hash_Table_Type
;
1021 New_Item
: Element_Type
)
1024 if Equivalent_Elements
(Node
.Element
, New_Item
) then
1025 pragma Assert
(Hash
(Node
.Element
) = Hash
(New_Item
));
1028 raise Program_Error
;
1031 Node
.Element
:= New_Item
; -- Note that this assignment can fail
1036 raise Program_Error
;
1039 HT_Ops
.Delete_Node_Sans_Free
(HT
, Node
);
1041 Insert_New_Element
: declare
1042 function New_Node
(Next
: Node_Access
) return Node_Access
;
1043 pragma Inline
(New_Node
);
1045 procedure Local_Insert
is
1046 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
1052 function New_Node
(Next
: Node_Access
) return Node_Access
is
1054 Node
.Element
:= New_Item
; -- Note that this assignment can fail
1059 Result
: Node_Access
;
1062 -- Start of processing for Insert_New_Element
1069 Inserted
=> Inserted
);
1076 null; -- Assignment must have failed
1077 end Insert_New_Element
;
1079 Reinsert_Old_Element
: declare
1080 function New_Node
(Next
: Node_Access
) return Node_Access
;
1081 pragma Inline
(New_Node
);
1083 procedure Local_Insert
is
1084 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
1090 function New_Node
(Next
: Node_Access
) return Node_Access
is
1096 Result
: Node_Access
;
1099 -- Start of processing for Reinsert_Old_Element
1104 Key
=> Node
.Element
,
1106 Inserted
=> Inserted
);
1110 end Reinsert_Old_Element
;
1112 raise Program_Error
;
1113 end Replace_Element
;
1115 procedure Replace_Element
1116 (Container
: in out Set
;
1118 New_Item
: Element_Type
)
1121 pragma Assert
(Vet
(Position
), "bad cursor in Replace_Element");
1123 if Position
.Node
= null then
1124 raise Constraint_Error
;
1127 if Position
.Container
/= Container
'Unrestricted_Access then
1128 raise Program_Error
;
1131 Replace_Element
(Container
.HT
, Position
.Node
, New_Item
);
1132 end Replace_Element
;
1134 ----------------------
1135 -- Reserve_Capacity --
1136 ----------------------
1138 procedure Reserve_Capacity
1139 (Container
: in out Set
;
1140 Capacity
: Count_Type
)
1143 HT_Ops
.Reserve_Capacity
(Container
.HT
, Capacity
);
1144 end Reserve_Capacity
;
1150 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
) is
1155 --------------------------
1156 -- Symmetric_Difference --
1157 --------------------------
1159 procedure Symmetric_Difference
1160 (Target
: in out Set
;
1164 if Target
'Address = Source
'Address then
1169 if Target
.HT
.Busy
> 0 then
1170 raise Program_Error
;
1174 N
: constant Count_Type
:= Target
.Length
+ Source
.Length
;
1176 if N
> HT_Ops
.Capacity
(Target
.HT
) then
1177 HT_Ops
.Reserve_Capacity
(Target
.HT
, N
);
1181 if Target
.Length
= 0 then
1182 Iterate_Source_When_Empty_Target
: declare
1183 procedure Process
(Src_Node
: Node_Access
);
1185 procedure Iterate
is
1186 new HT_Ops
.Generic_Iteration
(Process
);
1192 procedure Process
(Src_Node
: Node_Access
) is
1193 E
: Element_Type
renames Src_Node
.Element
;
1194 B
: Buckets_Type
renames Target
.HT
.Buckets
.all;
1195 J
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
1196 N
: Count_Type
renames Target
.HT
.Length
;
1199 B
(J
) := new Node_Type
'(E, B (J));
1203 -- Start of processing for Iterate_Source_When_Empty_Target
1206 Iterate (Source.HT);
1207 end Iterate_Source_When_Empty_Target;
1210 Iterate_Source : declare
1211 procedure Process (Src_Node : Node_Access);
1213 procedure Iterate is
1214 new HT_Ops.Generic_Iteration (Process);
1220 procedure Process (Src_Node : Node_Access) is
1221 E : Element_Type renames Src_Node.Element;
1222 B : Buckets_Type renames Target.HT.Buckets.all;
1223 J : constant Hash_Type := Hash (E) mod B'Length;
1224 N : Count_Type renames Target.HT.Length;
1227 if B (J) = null then
1228 B (J) := new Node_Type'(E
, null);
1231 elsif Equivalent_Elements
(E
, B
(J
).Element
) then
1233 X
: Node_Access
:= B
(J
);
1235 B
(J
) := B
(J
).Next
;
1242 Prev
: Node_Access
:= B
(J
);
1243 Curr
: Node_Access
:= Prev
.Next
;
1246 while Curr
/= null loop
1247 if Equivalent_Elements
(E
, Curr
.Element
) then
1248 Prev
.Next
:= Curr
.Next
;
1258 B
(J
) := new Node_Type
'(E, B (J));
1264 -- Start of processing for Iterate_Source
1267 Iterate (Source.HT);
1270 end Symmetric_Difference;
1272 function Symmetric_Difference (Left, Right : Set) return Set is
1273 Buckets : HT_Types.Buckets_Access;
1274 Length : Count_Type;
1277 if Left'Address = Right'Address then
1281 if Right.Length = 0 then
1285 if Left.Length = 0 then
1290 Size : constant Hash_Type :=
1291 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1293 Buckets := new Buckets_Type (0 .. Size - 1);
1298 Iterate_Left : declare
1299 procedure Process (L_Node : Node_Access);
1301 procedure Iterate is
1302 new HT_Ops.Generic_Iteration (Process);
1308 procedure Process (L_Node : Node_Access) is
1310 if not Is_In (Right.HT, L_Node) then
1312 E : Element_Type renames L_Node.Element;
1313 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1316 Buckets (J) := new Node_Type'(E
, Buckets
(J
));
1317 Length
:= Length
+ 1;
1322 -- Start of processing for Iterate_Left
1328 HT_Ops
.Free_Hash_Table
(Buckets
);
1332 Iterate_Right
: declare
1333 procedure Process
(R_Node
: Node_Access
);
1335 procedure Iterate
is
1336 new HT_Ops
.Generic_Iteration
(Process
);
1342 procedure Process
(R_Node
: Node_Access
) is
1344 if not Is_In
(Left
.HT
, R_Node
) then
1346 E
: Element_Type
renames R_Node
.Element
;
1347 J
: constant Hash_Type
:= Hash
(E
) mod Buckets
'Length;
1350 Buckets
(J
) := new Node_Type
'(E, Buckets (J));
1351 Length := Length + 1;
1356 -- Start of processing for Iterate_Right
1362 HT_Ops.Free_Hash_Table (Buckets);
1366 return (Controlled with HT => (Buckets, Length, 0, 0));
1367 end Symmetric_Difference;
1374 (Target : in out Set;
1377 procedure Process (Src_Node : Node_Access);
1379 procedure Iterate is
1380 new HT_Ops.Generic_Iteration (Process);
1386 procedure Process (Src_Node : Node_Access) is
1387 function New_Node (Next : Node_Access) return Node_Access;
1388 pragma Inline (New_Node);
1391 new Element_Keys.Generic_Conditional_Insert (New_Node);
1397 function New_Node (Next : Node_Access) return Node_Access is
1398 Node : constant Node_Access :=
1399 new Node_Type'(Src_Node
.Element
, Next
);
1404 Tgt_Node
: Node_Access
;
1407 -- Start of processing for Process
1410 Insert
(Target
.HT
, Src_Node
.Element
, Tgt_Node
, Success
);
1413 -- Start of processing for Union
1416 if Target
'Address = Source
'Address then
1420 if Target
.HT
.Busy
> 0 then
1421 raise Program_Error
;
1425 N
: constant Count_Type
:= Target
.Length
+ Source
.Length
;
1427 if N
> HT_Ops
.Capacity
(Target
.HT
) then
1428 HT_Ops
.Reserve_Capacity
(Target
.HT
, N
);
1432 Iterate
(Source
.HT
);
1435 function Union
(Left
, Right
: Set
) return Set
is
1436 Buckets
: HT_Types
.Buckets_Access
;
1437 Length
: Count_Type
;
1440 if Left
'Address = Right
'Address then
1444 if Right
.Length
= 0 then
1448 if Left
.Length
= 0 then
1453 Size
: constant Hash_Type
:=
1454 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1456 Buckets
:= new Buckets_Type
(0 .. Size
- 1);
1459 Iterate_Left
: declare
1460 procedure Process
(L_Node
: Node_Access
);
1462 procedure Iterate
is
1463 new HT_Ops
.Generic_Iteration
(Process
);
1469 procedure Process
(L_Node
: Node_Access
) is
1470 J
: constant Hash_Type
:=
1471 Hash
(L_Node
.Element
) mod Buckets
'Length;
1474 Buckets
(J
) := new Node_Type
'(L_Node.Element, Buckets (J));
1477 -- Start of processing for Iterate_Left
1483 HT_Ops.Free_Hash_Table (Buckets);
1487 Length := Left.Length;
1489 Iterate_Right : declare
1490 procedure Process (Src_Node : Node_Access);
1492 procedure Iterate is
1493 new HT_Ops.Generic_Iteration (Process);
1499 procedure Process (Src_Node : Node_Access) is
1500 J : constant Hash_Type :=
1501 Hash (Src_Node.Element) mod Buckets'Length;
1503 Tgt_Node : Node_Access := Buckets (J);
1506 while Tgt_Node /= null loop
1507 if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1511 Tgt_Node := Next (Tgt_Node);
1514 Buckets (J) := new Node_Type'(Src_Node
.Element
, Buckets
(J
));
1515 Length
:= Length
+ 1;
1518 -- Start of processing for Iterate_Right
1524 HT_Ops
.Free_Hash_Table
(Buckets
);
1528 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
1535 function Vet
(Position
: Cursor
) return Boolean is
1537 if Position
.Node
= null then
1538 return Position
.Container
= null;
1541 if Position
.Container
= null then
1545 if Position
.Node
.Next
= Position
.Node
then
1550 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
1554 if HT
.Length
= 0 then
1558 if HT
.Buckets
= null
1559 or else HT
.Buckets
'Length = 0
1564 X
:= HT
.Buckets
(Element_Keys
.Index
(HT
, Position
.Node
.Element
));
1566 for J
in 1 .. HT
.Length
loop
1567 if X
= Position
.Node
then
1575 if X
= X
.Next
then -- to prevent unnecessary looping
1591 (Stream
: access Root_Stream_Type
'Class;
1595 Write_Nodes
(Stream
, Container
.HT
);
1602 procedure Write_Node
1603 (Stream
: access Root_Stream_Type
'Class;
1607 Element_Type
'Write (Stream
, Node
.Element
);
1610 package body Generic_Keys
is
1612 -----------------------
1613 -- Local Subprograms --
1614 -----------------------
1616 function Equivalent_Key_Node
1618 Node
: Node_Access
) return Boolean;
1619 pragma Inline
(Equivalent_Key_Node
);
1621 --------------------------
1622 -- Local Instantiations --
1623 --------------------------
1626 new Hash_Tables
.Generic_Keys
1627 (HT_Types
=> HT_Types
,
1629 Set_Next
=> Set_Next
,
1630 Key_Type
=> Key_Type
,
1632 Equivalent_Keys
=> Equivalent_Key_Node
);
1640 Key
: Key_Type
) return Boolean
1643 return Find
(Container
, Key
) /= No_Element
;
1651 (Container
: in out Set
;
1657 Key_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Key
, X
);
1660 raise Constraint_Error
;
1672 Key
: Key_Type
) return Element_Type
1674 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.HT
, Key
);
1677 return Node
.Element
;
1680 -------------------------
1681 -- Equivalent_Key_Node --
1682 -------------------------
1684 function Equivalent_Key_Node
1686 Node
: Node_Access
) return Boolean
1689 return Equivalent_Keys
(Key
, Generic_Keys
.Key
(Node
.Element
));
1690 end Equivalent_Key_Node
;
1697 (Container
: in out Set
;
1702 Key_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Key
, X
);
1712 Key
: Key_Type
) return Cursor
1714 Node
: constant Node_Access
:=
1715 Key_Keys
.Find
(Container
.HT
, Key
);
1722 return Cursor
'(Container'Unrestricted_Access, Node);
1729 function Key (Position : Cursor) return Key_Type is
1731 pragma Assert (Vet (Position), "bad cursor in function Key");
1733 if Position.Node = null then
1734 raise Constraint_Error;
1737 return Key (Position.Node.Element);
1745 (Container : in out Set;
1747 New_Item : Element_Type)
1749 Node : constant Node_Access :=
1750 Key_Keys.Find (Container.HT, Key);
1754 raise Constraint_Error;
1757 Replace_Element (Container.HT, Node, New_Item);
1760 -----------------------------------
1761 -- Update_Element_Preserving_Key --
1762 -----------------------------------
1764 procedure Update_Element_Preserving_Key
1765 (Container : in out Set;
1767 Process : not null access
1768 procedure (Element : in out Element_Type))
1770 HT : Hash_Table_Type renames Container.HT;
1776 "bad cursor in Update_Element_Preserving_Key");
1778 if Position.Node = null then
1779 raise Constraint_Error;
1782 if Position.Container /= Container'Unrestricted_Access then
1783 raise Program_Error;
1786 if HT.Buckets = null
1787 or else HT.Buckets'Length = 0
1788 or else HT.Length = 0
1789 or else Position.Node.Next = Position.Node
1791 raise Program_Error;
1794 Indx := HT_Ops.Index (HT, Position.Node);
1797 E : Element_Type renames Position.Node.Element;
1798 K : constant Key_Type := Key (E);
1800 B : Natural renames HT.Busy;
1801 L : Natural renames HT.Lock;
1819 if Equivalent_Keys (K, Key (E)) then
1820 pragma Assert (Hash (K) = Hash (E));
1825 if HT.Buckets (Indx) = Position.Node then
1826 HT.Buckets (Indx) := Position.Node.Next;
1830 Prev : Node_Access := HT.Buckets (Indx);
1833 while Prev.Next /= Position.Node loop
1837 raise Program_Error;
1841 Prev.Next := Position.Node.Next;
1845 HT.Length := HT.Length - 1;
1848 X : Node_Access := Position.Node;
1854 raise Program_Error;
1855 end Update_Element_Preserving_Key;
1859 end Ada.Containers.Hashed_Sets;