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-2005, Free Software Foundation, Inc. --
12 -- This specification is derived from the Ada Reference Manual for use with --
13 -- GNAT. The copyright notice above, and the license provisions that follow --
14 -- apply solely to the contents of the part following the private keyword. --
16 -- GNAT is free software; you can redistribute it and/or modify it under --
17 -- terms of the GNU General Public License as published by the Free Soft- --
18 -- ware Foundation; either version 2, or (at your option) any later ver- --
19 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
20 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
21 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
22 -- for more details. You should have received a copy of the GNU General --
23 -- Public License distributed with GNAT; see file COPYING. If not, write --
24 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
25 -- Boston, MA 02110-1301, USA. --
27 -- As a special exception, if other files instantiate generics from this --
28 -- unit, or you link this unit with other files to produce an executable, --
29 -- this unit does not by itself cause the resulting executable to be --
30 -- covered by the GNU General Public License. This exception does not --
31 -- however invalidate any other reasons why the executable file might be --
32 -- covered by the GNU Public License. --
34 -- This unit has originally being developed by Matthew J Heaney. --
35 ------------------------------------------------------------------------------
37 with Ada
.Unchecked_Deallocation
;
39 with Ada
.Containers
.Hash_Tables
.Generic_Operations
;
40 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Operations
);
42 with Ada
.Containers
.Hash_Tables
.Generic_Keys
;
43 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Keys
);
45 with System
; use type System
.Address
;
47 with Ada
.Containers
.Prime_Numbers
;
49 package body Ada
.Containers
.Indefinite_Hashed_Sets
is
51 -----------------------
52 -- Local Subprograms --
53 -----------------------
55 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
56 pragma Inline
(Copy_Node
);
58 function Equivalent_Keys
60 Node
: Node_Access
) return Boolean;
61 pragma Inline
(Equivalent_Keys
);
63 function Find_Equal_Key
64 (R_HT
: Hash_Table_Type
;
65 L_Node
: Node_Access
) return Boolean;
67 function Find_Equivalent_Key
68 (R_HT
: Hash_Table_Type
;
69 L_Node
: Node_Access
) return Boolean;
71 procedure Free
(X
: in out Node_Access
);
73 function Hash_Node
(Node
: Node_Access
) return Hash_Type
;
74 pragma Inline
(Hash_Node
);
77 (HT
: in out Hash_Table_Type
;
78 New_Item
: Element_Type
;
79 Node
: out Node_Access
;
80 Inserted
: out Boolean);
82 function Is_In
(HT
: Hash_Table_Type
; Key
: Node_Access
) return Boolean;
83 pragma Inline
(Is_In
);
85 function Next
(Node
: Node_Access
) return Node_Access
;
88 function Read_Node
(Stream
: access Root_Stream_Type
'Class)
90 pragma Inline
(Read_Node
);
92 procedure Replace_Element
93 (HT
: in out Hash_Table_Type
;
95 New_Item
: Element_Type
);
97 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
);
98 pragma Inline
(Set_Next
);
100 function Vet
(Position
: Cursor
) return Boolean;
103 (Stream
: access Root_Stream_Type
'Class;
105 pragma Inline
(Write_Node
);
107 --------------------------
108 -- Local Instantiations --
109 --------------------------
111 procedure Free_Element
is
112 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
115 new Hash_Tables
.Generic_Operations
116 (HT_Types
=> HT_Types
,
117 Hash_Node
=> Hash_Node
,
119 Set_Next
=> Set_Next
,
120 Copy_Node
=> Copy_Node
,
123 package Element_Keys
is
124 new Hash_Tables
.Generic_Keys
125 (HT_Types
=> HT_Types
,
127 Set_Next
=> Set_Next
,
128 Key_Type
=> Element_Type
,
130 Equivalent_Keys
=> Equivalent_Keys
);
133 new HT_Ops
.Generic_Equal
(Find_Equal_Key
);
135 function Is_Equivalent
is
136 new HT_Ops
.Generic_Equal
(Find_Equivalent_Key
);
138 procedure Read_Nodes
is
139 new HT_Ops
.Generic_Read
(Read_Node
);
141 procedure Write_Nodes
is
142 new HT_Ops
.Generic_Write
(Write_Node
);
148 function "=" (Left
, Right
: Set
) return Boolean is
150 return Is_Equal
(Left
.HT
, Right
.HT
);
157 procedure Adjust
(Container
: in out Set
) is
159 HT_Ops
.Adjust
(Container
.HT
);
166 function Capacity
(Container
: Set
) return Count_Type
is
168 return HT_Ops
.Capacity
(Container
.HT
);
175 procedure Clear
(Container
: in out Set
) is
177 HT_Ops
.Clear
(Container
.HT
);
184 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean is
186 return Find
(Container
, Item
) /= No_Element
;
193 function Copy_Node
(Source
: Node_Access
) return Node_Access
is
194 E
: Element_Access
:= new Element_Type
'(Source.Element.all);
196 return new Node_Type'(Element
=> E
, Next
=> null);
208 (Container
: in out Set
;
214 Element_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Item
, X
);
217 raise Constraint_Error
;
224 (Container
: in out Set
;
225 Position
: in out Cursor
)
228 pragma Assert
(Vet
(Position
), "bad cursor in Delete");
230 if Position
.Node
= null then
231 raise Constraint_Error
;
234 if Position
.Node
.Element
= null then
238 if Position
.Container
/= Container
'Unrestricted_Access then
242 if Container
.HT
.Busy
> 0 then
246 HT_Ops
.Delete_Node_Sans_Free
(Container
.HT
, Position
.Node
);
248 Free
(Position
.Node
);
249 Position
.Container
:= null;
257 (Target
: in out Set
;
260 Tgt_Node
: Node_Access
;
263 if Target
'Address = Source
'Address then
268 if Source
.Length
= 0 then
272 if Target
.HT
.Busy
> 0 then
276 -- TODO: This can be written in terms of a loop instead as
277 -- active-iterator style, sort of like a passive iterator.
279 Tgt_Node
:= HT_Ops
.First
(Target
.HT
);
280 while Tgt_Node
/= null loop
281 if Is_In
(Source
.HT
, Tgt_Node
) then
283 X
: Node_Access
:= Tgt_Node
;
285 Tgt_Node
:= HT_Ops
.Next
(Target
.HT
, Tgt_Node
);
286 HT_Ops
.Delete_Node_Sans_Free
(Target
.HT
, X
);
291 Tgt_Node
:= HT_Ops
.Next
(Target
.HT
, Tgt_Node
);
296 function Difference
(Left
, Right
: Set
) return Set
is
297 Buckets
: HT_Types
.Buckets_Access
;
301 if Left
'Address = Right
'Address then
305 if Left
.Length
= 0 then
309 if Right
.Length
= 0 then
314 Size
: constant Hash_Type
:= Prime_Numbers
.To_Prime
(Left
.Length
);
316 Buckets
:= new Buckets_Type
(0 .. Size
- 1);
321 Iterate_Left
: declare
322 procedure Process
(L_Node
: Node_Access
);
325 new HT_Ops
.Generic_Iteration
(Process
);
331 procedure Process
(L_Node
: Node_Access
) is
333 if not Is_In
(Right
.HT
, L_Node
) then
335 Src
: Element_Type
renames L_Node
.Element
.all;
336 Indx
: constant Hash_Type
:= Hash
(Src
) mod Buckets
'Length;
337 Bucket
: Node_Access
renames Buckets
(Indx
);
338 Tgt
: Element_Access
:= new Element_Type
'(Src);
340 Bucket := new Node_Type'(Tgt
, Bucket
);
347 Length
:= Length
+ 1;
351 -- Start of processing for Iterate_Left
357 HT_Ops
.Free_Hash_Table
(Buckets
);
361 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
368 function Element
(Position
: Cursor
) return Element_Type
is
370 pragma Assert
(Vet
(Position
), "bad cursor in function Element");
372 if Position
.Node
= null then
373 raise Constraint_Error
;
376 if Position
.Node
.Element
= null then -- handle dangling reference
380 return Position
.Node
.Element
.all;
383 ---------------------
384 -- Equivalent_Sets --
385 ---------------------
387 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
389 return Is_Equivalent
(Left
.HT
, Right
.HT
);
392 -------------------------
393 -- Equivalent_Elements --
394 -------------------------
396 function Equivalent_Elements
(Left
, Right
: Cursor
)
399 pragma Assert
(Vet
(Left
), "bad Left cursor in Equivalent_Keys");
400 pragma Assert
(Vet
(Right
), "bad Right cursor in Equivalent_Keys");
403 or else Right
.Node
= null
405 raise Constraint_Error
;
408 if Left
.Node
.Element
= null -- handle dangling cursor reference
409 or else Right
.Node
.Element
= null
414 return Equivalent_Elements
415 (Left
.Node
.Element
.all,
416 Right
.Node
.Element
.all);
417 end Equivalent_Elements
;
419 function Equivalent_Elements
(Left
: Cursor
; Right
: Element_Type
)
422 pragma Assert
(Vet
(Left
), "bad Left cursor in Equivalent_Keys");
424 if Left
.Node
= null then
425 raise Constraint_Error
;
428 if Left
.Node
.Element
= null then -- handling dangling reference
432 return Equivalent_Elements
(Left
.Node
.Element
.all, Right
);
433 end Equivalent_Elements
;
435 function Equivalent_Elements
(Left
: Element_Type
; Right
: Cursor
)
438 pragma Assert
(Vet
(Right
), "bad Right cursor in Equivalent_Keys");
440 if Right
.Node
= null then
441 raise Constraint_Error
;
444 if Right
.Node
.Element
= null then -- handle dangling cursor reference
448 return Equivalent_Elements
(Left
, Right
.Node
.Element
.all);
449 end Equivalent_Elements
;
451 ---------------------
452 -- Equivalent_Keys --
453 ---------------------
455 function Equivalent_Keys
(Key
: Element_Type
; Node
: Node_Access
)
458 return Equivalent_Elements
(Key
, Node
.Element
.all);
466 (Container
: in out Set
;
471 Element_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Item
, X
);
479 procedure Finalize
(Container
: in out Set
) is
481 HT_Ops
.Finalize
(Container
.HT
);
490 Item
: Element_Type
) return Cursor
492 Node
: constant Node_Access
:= Element_Keys
.Find
(Container
.HT
, Item
);
499 return Cursor
'(Container'Unrestricted_Access, Node);
506 function Find_Equal_Key
507 (R_HT : Hash_Table_Type;
508 L_Node : Node_Access) return Boolean
510 R_Index : constant Hash_Type :=
511 Element_Keys.Index (R_HT, L_Node.Element.all);
513 R_Node : Node_Access := R_HT.Buckets (R_Index);
517 if R_Node = null then
521 if L_Node.Element.all = R_Node.Element.all then
525 R_Node := Next (R_Node);
529 -------------------------
530 -- Find_Equivalent_Key --
531 -------------------------
533 function Find_Equivalent_Key
534 (R_HT : Hash_Table_Type;
535 L_Node : Node_Access) return Boolean
537 R_Index : constant Hash_Type :=
538 Element_Keys.Index (R_HT, L_Node.Element.all);
540 R_Node : Node_Access := R_HT.Buckets (R_Index);
544 if R_Node = null then
548 if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
552 R_Node := Next (R_Node);
554 end Find_Equivalent_Key;
560 function First (Container : Set) return Cursor is
561 Node : constant Node_Access := HT_Ops.First (Container.HT);
568 return Cursor'(Container
'Unrestricted_Access, Node
);
575 procedure Free
(X
: in out Node_Access
) is
576 procedure Deallocate
is
577 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
584 X
.Next
:= X
; -- detect mischief (in Vet)
587 Free_Element
(X
.Element
);
602 function Has_Element
(Position
: Cursor
) return Boolean is
604 pragma Assert
(Vet
(Position
), "bad cursor in Has_Element");
605 return Position
.Node
/= null;
612 function Hash_Node
(Node
: Node_Access
) return Hash_Type
is
614 return Hash
(Node
.Element
.all);
622 (Container
: in out Set
;
623 New_Item
: Element_Type
)
631 Insert
(Container
, New_Item
, Position
, Inserted
);
634 if Container
.HT
.Lock
> 0 then
638 X
:= Position
.Node
.Element
;
640 Position
.Node
.Element
:= new Element_Type
'(New_Item);
651 (Container : in out Set;
652 New_Item : Element_Type;
653 Position : out Cursor;
654 Inserted : out Boolean)
657 Insert (Container.HT, New_Item, Position.Node, Inserted);
658 Position.Container := Container'Unchecked_Access;
662 (Container : in out Set;
663 New_Item : Element_Type)
669 Insert (Container, New_Item, Position, Inserted);
672 raise Constraint_Error;
677 (HT : in out Hash_Table_Type;
678 New_Item : Element_Type;
679 Node : out Node_Access;
680 Inserted : out Boolean)
682 function New_Node (Next : Node_Access) return Node_Access;
683 pragma Inline (New_Node);
685 procedure Local_Insert is
686 new Element_Keys.Generic_Conditional_Insert (New_Node);
692 function New_Node (Next : Node_Access) return Node_Access is
693 Element : Element_Access := new Element_Type'(New_Item
);
696 return new Node_Type
'(Element, Next);
699 Free_Element (Element);
703 -- Start of processing for Insert
706 if HT_Ops.Capacity (HT) = 0 then
707 HT_Ops.Reserve_Capacity (HT, 1);
710 Local_Insert (HT, New_Item, Node, Inserted);
713 and then HT.Length > HT_Ops.Capacity (HT)
715 HT_Ops.Reserve_Capacity (HT, HT.Length);
723 procedure Intersection
724 (Target : in out Set;
727 Tgt_Node : Node_Access;
730 if Target'Address = Source'Address then
734 if Source.Length = 0 then
739 if Target.HT.Busy > 0 then
743 -- TODO: optimize this to use an explicit
744 -- loop instead of an active iterator
745 -- (similar to how a passive iterator is
748 -- Another possibility is to test which
749 -- set is smaller, and iterate over the
752 Tgt_Node := HT_Ops.First (Target.HT);
753 while Tgt_Node /= null loop
754 if Is_In (Source.HT, Tgt_Node) then
755 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
759 X : Node_Access := Tgt_Node;
761 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
762 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
769 function Intersection (Left, Right : Set) return Set is
770 Buckets : HT_Types.Buckets_Access;
774 if Left'Address = Right'Address then
778 Length := Count_Type'Min (Left.Length, Right.Length);
785 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
787 Buckets := new Buckets_Type (0 .. Size - 1);
792 Iterate_Left : declare
793 procedure Process (L_Node : Node_Access);
796 new HT_Ops.Generic_Iteration (Process);
802 procedure Process (L_Node : Node_Access) is
804 if Is_In (Right.HT, L_Node) then
806 Src : Element_Type renames L_Node.Element.all;
808 Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
810 Bucket : Node_Access renames Buckets (Indx);
812 Tgt : Element_Access := new Element_Type'(Src
);
815 Bucket
:= new Node_Type
'(Tgt, Bucket);
822 Length := Length + 1;
826 -- Start of processing for Iterate_Left
832 HT_Ops.Free_Hash_Table (Buckets);
836 return (Controlled with HT => (Buckets, Length, 0, 0));
843 function Is_Empty (Container : Set) return Boolean is
845 return Container.HT.Length = 0;
852 function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
854 return Element_Keys.Find (HT, Key.Element.all) /= null;
863 Of_Set : Set) return Boolean
865 Subset_Node : Node_Access;
868 if Subset'Address = Of_Set'Address then
872 if Subset.Length > Of_Set.Length then
876 -- TODO: rewrite this to loop in the
877 -- style of a passive iterator.
879 Subset_Node := HT_Ops.First (Subset.HT);
880 while Subset_Node /= null loop
881 if not Is_In (Of_Set.HT, Subset_Node) then
885 Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
897 Process : not null access procedure (Position : Cursor))
899 procedure Process_Node (Node : Node_Access);
900 pragma Inline (Process_Node);
903 new HT_Ops.Generic_Iteration (Process_Node);
909 procedure Process_Node (Node : Node_Access) is
911 Process (Cursor'(Container
'Unrestricted_Access, Node
));
914 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.all.HT
;
916 -- Start of processing for Iterate
919 -- TODO: resolve whether HT_Ops.Generic_Iteration should
920 -- manipulate busy bit.
929 function Length
(Container
: Set
) return Count_Type
is
931 return Container
.HT
.Length
;
938 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
940 HT_Ops
.Move
(Target
=> Target
.HT
, Source
=> Source
.HT
);
947 function Next
(Node
: Node_Access
) return Node_Access
is
952 function Next
(Position
: Cursor
) return Cursor
is
954 pragma Assert
(Vet
(Position
), "bad cursor in function Next");
956 if Position
.Node
= null then
960 if Position
.Node
.Element
= null then
965 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
966 Node
: constant Node_Access
:= HT_Ops
.Next
(HT
, Position
.Node
);
973 return Cursor
'(Position.Container, Node);
977 procedure Next (Position : in out Cursor) is
979 Position := Next (Position);
986 function Overlap (Left, Right : Set) return Boolean is
987 Left_Node : Node_Access;
990 if Right.Length = 0 then
994 if Left'Address = Right'Address then
998 Left_Node := HT_Ops.First (Left.HT);
999 while Left_Node /= null loop
1000 if Is_In (Right.HT, Left_Node) then
1004 Left_Node := HT_Ops.Next (Left.HT, Left_Node);
1014 procedure Query_Element
1016 Process : not null access procedure (Element : Element_Type))
1019 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1021 if Position.Node = null then
1022 raise Constraint_Error;
1025 if Position.Node.Element = null then
1026 raise Program_Error;
1030 HT : Hash_Table_Type renames
1031 Position.Container'Unrestricted_Access.all.HT;
1033 B : Natural renames HT.Busy;
1034 L : Natural renames HT.Lock;
1041 Process (Position.Node.Element.all);
1059 (Stream : access Root_Stream_Type'Class;
1060 Container : out Set)
1063 Read_Nodes (Stream, Container.HT);
1067 (Stream : access Root_Stream_Type'Class;
1071 raise Program_Error;
1079 (Stream : access Root_Stream_Type'Class) return Node_Access
1081 X : Element_Access := new Element_Type'(Element_Type
'Input (Stream
));
1084 return new Node_Type
'(X, null);
1096 (Container : in out Set;
1097 New_Item : Element_Type)
1099 Node : constant Node_Access :=
1100 Element_Keys.Find (Container.HT, New_Item);
1106 raise Constraint_Error;
1109 if Container.HT.Lock > 0 then
1110 raise Program_Error;
1115 Node.Element := new Element_Type'(New_Item
);
1120 ---------------------
1121 -- Replace_Element --
1122 ---------------------
1124 procedure Replace_Element
1125 (HT
: in out Hash_Table_Type
;
1127 New_Item
: Element_Type
)
1130 if Equivalent_Elements
(Node
.Element
.all, New_Item
) then
1131 pragma Assert
(Hash
(Node
.Element
.all) = Hash
(New_Item
));
1134 raise Program_Error
;
1138 X
: Element_Access
:= Node
.Element
;
1140 Node
.Element
:= new Element_Type
'(New_Item); -- OK if fails
1148 raise Program_Error;
1151 HT_Ops.Delete_Node_Sans_Free (HT, Node);
1153 Insert_New_Element : declare
1154 function New_Node (Next : Node_Access) return Node_Access;
1155 pragma Inline (New_Node);
1158 new Element_Keys.Generic_Conditional_Insert (New_Node);
1160 ------------------------
1161 -- Insert_New_Element --
1162 ------------------------
1164 function New_Node (Next : Node_Access) return Node_Access is
1166 Node.Element := new Element_Type'(New_Item
); -- OK if fails
1171 Result
: Node_Access
;
1174 X
: Element_Access
:= Node
.Element
;
1176 -- Start of processing for Insert_New_Element
1179 Attempt_Insert
: begin
1184 Inserted
=> Inserted
);
1187 Inserted
:= False; -- Assignment failed
1191 Free_Element
(X
); -- Just propagate if fails
1194 end Insert_New_Element
;
1196 Reinsert_Old_Element
:
1198 function New_Node
(Next
: Node_Access
) return Node_Access
;
1199 pragma Inline
(New_Node
);
1202 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
1208 function New_Node
(Next
: Node_Access
) return Node_Access
is
1214 Result
: Node_Access
;
1217 -- Start of processing for Reinsert_Old_Element
1222 Key
=> Node
.Element
.all,
1224 Inserted
=> Inserted
);
1228 end Reinsert_Old_Element
;
1230 raise Program_Error
;
1231 end Replace_Element
;
1233 procedure Replace_Element
1234 (Container
: in out Set
;
1236 New_Item
: Element_Type
)
1239 pragma Assert
(Vet
(Position
), "bad cursor in Replace_Element");
1241 if Position
.Node
= null then
1242 raise Constraint_Error
;
1245 if Position
.Node
.Element
= null then
1246 raise Program_Error
;
1249 if Position
.Container
/= Container
'Unrestricted_Access then
1250 raise Program_Error
;
1253 Replace_Element
(Container
.HT
, Position
.Node
, New_Item
);
1254 end Replace_Element
;
1256 ----------------------
1257 -- Reserve_Capacity --
1258 ----------------------
1260 procedure Reserve_Capacity
1261 (Container
: in out Set
;
1262 Capacity
: Count_Type
)
1265 HT_Ops
.Reserve_Capacity
(Container
.HT
, Capacity
);
1266 end Reserve_Capacity
;
1272 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
) is
1277 --------------------------
1278 -- Symmetric_Difference --
1279 --------------------------
1281 procedure Symmetric_Difference
1282 (Target
: in out Set
;
1286 if Target
'Address = Source
'Address then
1291 if Target
.HT
.Busy
> 0 then
1292 raise Program_Error
;
1296 N
: constant Count_Type
:= Target
.Length
+ Source
.Length
;
1298 if N
> HT_Ops
.Capacity
(Target
.HT
) then
1299 HT_Ops
.Reserve_Capacity
(Target
.HT
, N
);
1303 if Target
.Length
= 0 then
1304 Iterate_Source_When_Empty_Target
: declare
1305 procedure Process
(Src_Node
: Node_Access
);
1307 procedure Iterate
is
1308 new HT_Ops
.Generic_Iteration
(Process
);
1314 procedure Process
(Src_Node
: Node_Access
) is
1315 E
: Element_Type
renames Src_Node
.Element
.all;
1316 B
: Buckets_Type
renames Target
.HT
.Buckets
.all;
1317 J
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
1318 N
: Count_Type
renames Target
.HT
.Length
;
1322 X
: Element_Access
:= new Element_Type
'(E);
1324 B (J) := new Node_Type'(X
, B
(J
));
1334 -- Start of processing for Iterate_Source_When_Empty_Target
1337 Iterate
(Source
.HT
);
1338 end Iterate_Source_When_Empty_Target
;
1341 Iterate_Source
: declare
1342 procedure Process
(Src_Node
: Node_Access
);
1344 procedure Iterate
is
1345 new HT_Ops
.Generic_Iteration
(Process
);
1351 procedure Process
(Src_Node
: Node_Access
) is
1352 E
: Element_Type
renames Src_Node
.Element
.all;
1353 B
: Buckets_Type
renames Target
.HT
.Buckets
.all;
1354 J
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
1355 N
: Count_Type
renames Target
.HT
.Length
;
1358 if B
(J
) = null then
1360 X
: Element_Access
:= new Element_Type
'(E);
1362 B (J) := new Node_Type'(X
, null);
1371 elsif Equivalent_Elements
(E
, B
(J
).Element
.all) then
1373 X
: Node_Access
:= B
(J
);
1375 B
(J
) := B
(J
).Next
;
1382 Prev
: Node_Access
:= B
(J
);
1383 Curr
: Node_Access
:= Prev
.Next
;
1386 while Curr
/= null loop
1387 if Equivalent_Elements
(E
, Curr
.Element
.all) then
1388 Prev
.Next
:= Curr
.Next
;
1399 X
: Element_Access
:= new Element_Type
'(E);
1401 B (J) := new Node_Type'(X
, B
(J
));
1413 -- Start of processing for Iterate_Source
1416 Iterate
(Source
.HT
);
1419 end Symmetric_Difference
;
1421 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
1422 Buckets
: HT_Types
.Buckets_Access
;
1423 Length
: Count_Type
;
1426 if Left
'Address = Right
'Address then
1430 if Right
.Length
= 0 then
1434 if Left
.Length
= 0 then
1439 Size
: constant Hash_Type
:=
1440 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1442 Buckets
:= new Buckets_Type
(0 .. Size
- 1);
1447 Iterate_Left
: declare
1448 procedure Process
(L_Node
: Node_Access
);
1450 procedure Iterate
is
1451 new HT_Ops
.Generic_Iteration
(Process
);
1457 procedure Process
(L_Node
: Node_Access
) is
1459 if not Is_In
(Right
.HT
, L_Node
) then
1461 E
: Element_Type
renames L_Node
.Element
.all;
1462 J
: constant Hash_Type
:= Hash
(E
) mod Buckets
'Length;
1466 X
: Element_Access
:= new Element_Type
'(E);
1468 Buckets (J) := new Node_Type'(X
, Buckets
(J
));
1475 Length
:= Length
+ 1;
1480 -- Start of processing for Iterate_Left
1486 HT_Ops
.Free_Hash_Table
(Buckets
);
1490 Iterate_Right
: declare
1491 procedure Process
(R_Node
: Node_Access
);
1493 procedure Iterate
is
1494 new HT_Ops
.Generic_Iteration
(Process
);
1500 procedure Process
(R_Node
: Node_Access
) is
1502 if not Is_In
(Left
.HT
, R_Node
) then
1504 E
: Element_Type
renames R_Node
.Element
.all;
1505 J
: constant Hash_Type
:= Hash
(E
) mod Buckets
'Length;
1509 X
: Element_Access
:= new Element_Type
'(E);
1511 Buckets (J) := new Node_Type'(X
, Buckets
(J
));
1518 Length
:= Length
+ 1;
1523 -- Start of processing for Iterate_Right
1529 HT_Ops
.Free_Hash_Table
(Buckets
);
1533 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
1534 end Symmetric_Difference
;
1540 function To_Set
(New_Item
: Element_Type
) return Set
is
1541 HT
: Hash_Table_Type
;
1546 Insert
(HT
, New_Item
, Node
, Inserted
);
1547 return Set
'(Controlled with HT);
1555 (Target : in out Set;
1558 procedure Process (Src_Node : Node_Access);
1560 procedure Iterate is
1561 new HT_Ops.Generic_Iteration (Process);
1567 procedure Process (Src_Node : Node_Access) is
1568 Src : Element_Type renames Src_Node.Element.all;
1570 function New_Node (Next : Node_Access) return Node_Access;
1571 pragma Inline (New_Node);
1574 new Element_Keys.Generic_Conditional_Insert (New_Node);
1580 function New_Node (Next : Node_Access) return Node_Access is
1581 Tgt : Element_Access := new Element_Type'(Src
);
1584 return new Node_Type
'(Tgt, Next);
1591 Tgt_Node : Node_Access;
1594 -- Start of processing for Process
1597 Insert (Target.HT, Src, Tgt_Node, Success);
1600 -- Start of processing for Union
1603 if Target'Address = Source'Address then
1607 if Target.HT.Busy > 0 then
1608 raise Program_Error;
1612 N : constant Count_Type := Target.Length + Source.Length;
1614 if N > HT_Ops.Capacity (Target.HT) then
1615 HT_Ops.Reserve_Capacity (Target.HT, N);
1619 Iterate (Source.HT);
1622 function Union (Left, Right : Set) return Set is
1623 Buckets : HT_Types.Buckets_Access;
1624 Length : Count_Type;
1627 if Left'Address = Right'Address then
1631 if Right.Length = 0 then
1635 if Left.Length = 0 then
1640 Size : constant Hash_Type :=
1641 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1643 Buckets := new Buckets_Type (0 .. Size - 1);
1646 Iterate_Left : declare
1647 procedure Process (L_Node : Node_Access);
1649 procedure Iterate is
1650 new HT_Ops.Generic_Iteration (Process);
1656 procedure Process (L_Node : Node_Access) is
1657 Src : Element_Type renames L_Node.Element.all;
1659 J : constant Hash_Type := Hash (Src) mod Buckets'Length;
1661 Bucket : Node_Access renames Buckets (J);
1663 Tgt : Element_Access := new Element_Type'(Src
);
1666 Bucket
:= new Node_Type
'(Tgt, Bucket);
1673 -- Start of processing for Process
1679 HT_Ops.Free_Hash_Table (Buckets);
1683 Length := Left.Length;
1685 Iterate_Right : declare
1686 procedure Process (Src_Node : Node_Access);
1688 procedure Iterate is
1689 new HT_Ops.Generic_Iteration (Process);
1695 procedure Process (Src_Node : Node_Access) is
1696 Src : Element_Type renames Src_Node.Element.all;
1697 Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
1699 Tgt_Node : Node_Access := Buckets (Idx);
1702 while Tgt_Node /= null loop
1703 if Equivalent_Elements (Src, Tgt_Node.Element.all) then
1706 Tgt_Node := Next (Tgt_Node);
1710 Tgt : Element_Access := new Element_Type'(Src
);
1712 Buckets
(Idx
) := new Node_Type
'(Tgt, Buckets (Idx));
1719 Length := Length + 1;
1722 -- Start of processing for Iterate_Right
1728 HT_Ops.Free_Hash_Table (Buckets);
1732 return (Controlled with HT => (Buckets, Length, 0, 0));
1739 function Vet (Position : Cursor) return Boolean is
1741 if Position.Node = null then
1742 return Position.Container = null;
1745 if Position.Container = null then
1749 if Position.Node.Next = Position.Node then
1753 if Position.Node.Element = null then
1758 HT : Hash_Table_Type renames Position.Container.HT;
1762 if HT.Length = 0 then
1766 if HT.Buckets = null
1767 or else HT.Buckets'Length = 0
1772 X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
1774 for J in 1 .. HT.Length loop
1775 if X = Position.Node then
1783 if X = X.Next then -- to prevent unnecessary looping
1799 (Stream : access Root_Stream_Type'Class;
1803 Write_Nodes (Stream, Container.HT);
1807 (Stream : access Root_Stream_Type'Class;
1811 raise Program_Error;
1818 procedure Write_Node
1819 (Stream : access Root_Stream_Type'Class;
1823 Element_Type'Output (Stream, Node.Element.all);
1826 package body Generic_Keys is
1828 -----------------------
1829 -- Local Subprograms --
1830 -----------------------
1832 function Equivalent_Key_Node
1834 Node : Node_Access) return Boolean;
1835 pragma Inline (Equivalent_Key_Node);
1837 --------------------------
1838 -- Local Instantiations --
1839 --------------------------
1842 new Hash_Tables.Generic_Keys
1843 (HT_Types => HT_Types,
1845 Set_Next => Set_Next,
1846 Key_Type => Key_Type,
1848 Equivalent_Keys => Equivalent_Key_Node);
1856 Key : Key_Type) return Boolean
1859 return Find (Container, Key) /= No_Element;
1867 (Container : in out Set;
1873 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1876 raise Constraint_Error;
1888 Key : Key_Type) return Element_Type
1890 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1892 return Node.Element.all;
1895 -------------------------
1896 -- Equivalent_Key_Node --
1897 -------------------------
1899 function Equivalent_Key_Node
1901 Node : Node_Access) return Boolean is
1903 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
1904 end Equivalent_Key_Node;
1911 (Container : in out Set;
1916 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1926 Key : Key_Type) return Cursor
1928 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1935 return Cursor'(Container
'Unrestricted_Access, Node
);
1942 function Key
(Position
: Cursor
) return Key_Type
is
1944 pragma Assert
(Vet
(Position
), "bad cursor in function Key");
1946 if Position
.Node
= null then
1947 raise Constraint_Error
;
1950 if Position
.Node
.Element
= null then
1951 raise Program_Error
;
1954 return Key
(Position
.Node
.Element
.all);
1962 (Container
: in out Set
;
1964 New_Item
: Element_Type
)
1966 Node
: constant Node_Access
:=
1967 Key_Keys
.Find
(Container
.HT
, Key
);
1971 raise Constraint_Error
;
1974 Replace_Element
(Container
.HT
, Node
, New_Item
);
1977 procedure Update_Element_Preserving_Key
1978 (Container
: in out Set
;
1979 Position
: in Cursor
;
1980 Process
: not null access
1981 procedure (Element
: in out Element_Type
))
1983 HT
: Hash_Table_Type
renames Container
.HT
;
1989 "bad cursor in Update_Element_Preserving_Key");
1991 if Position
.Node
= null then
1992 raise Constraint_Error
;
1995 if Position
.Node
.Element
= null
1996 or else Position
.Node
.Next
= Position
.Node
1998 raise Program_Error
;
2001 if Position
.Container
/= Container
'Unrestricted_Access then
2002 raise Program_Error
;
2005 if HT
.Buckets
= null
2006 or else HT
.Buckets
'Length = 0
2007 or else HT
.Length
= 0
2009 raise Program_Error
;
2012 Indx
:= HT_Ops
.Index
(HT
, Position
.Node
);
2015 E
: Element_Type
renames Position
.Node
.Element
.all;
2016 K
: constant Key_Type
:= Key
(E
);
2018 B
: Natural renames HT
.Busy
;
2019 L
: Natural renames HT
.Lock
;
2037 if Equivalent_Keys
(K
, Key
(E
)) then
2038 pragma Assert
(Hash
(K
) = Hash
(E
));
2043 if HT
.Buckets
(Indx
) = Position
.Node
then
2044 HT
.Buckets
(Indx
) := Position
.Node
.Next
;
2048 Prev
: Node_Access
:= HT
.Buckets
(Indx
);
2051 while Prev
.Next
/= Position
.Node
loop
2055 raise Program_Error
;
2059 Prev
.Next
:= Position
.Node
.Next
;
2063 HT
.Length
:= HT
.Length
- 1;
2066 X
: Node_Access
:= Position
.Node
;
2072 raise Program_Error
;
2073 end Update_Element_Preserving_Key
;
2077 end Ada
.Containers
.Indefinite_Hashed_Sets
;