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 -- 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 Ada
.Containers
.Prime_Numbers
;
47 with System
; use type System
.Address
;
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
with "attempt to delete element not in set";
224 (Container
: in out Set
;
225 Position
: in out Cursor
)
228 if Position
.Node
= null then
229 raise Constraint_Error
with "Position cursor equals No_Element";
232 if Position
.Node
.Element
= null then
233 raise Program_Error
with "Position cursor is bad";
236 if Position
.Container
/= Container
'Unrestricted_Access then
237 raise Program_Error
with "Position cursor designates wrong set";
240 if Container
.HT
.Busy
> 0 then
241 raise Program_Error
with
242 "attempt to tamper with elements (set is busy)";
245 pragma Assert
(Vet
(Position
), "Position cursor is bad");
247 HT_Ops
.Delete_Node_Sans_Free
(Container
.HT
, Position
.Node
);
249 Free
(Position
.Node
);
250 Position
.Container
:= null;
258 (Target
: in out Set
;
261 Tgt_Node
: Node_Access
;
264 if Target
'Address = Source
'Address then
269 if Source
.Length
= 0 then
273 if Target
.HT
.Busy
> 0 then
274 raise Program_Error
with
275 "attempt to tamper with elements (set is busy)";
278 -- TODO: This can be written in terms of a loop instead as
279 -- active-iterator style, sort of like a passive iterator.
281 Tgt_Node
:= HT_Ops
.First
(Target
.HT
);
282 while Tgt_Node
/= null loop
283 if Is_In
(Source
.HT
, Tgt_Node
) then
285 X
: Node_Access
:= Tgt_Node
;
287 Tgt_Node
:= HT_Ops
.Next
(Target
.HT
, Tgt_Node
);
288 HT_Ops
.Delete_Node_Sans_Free
(Target
.HT
, X
);
293 Tgt_Node
:= HT_Ops
.Next
(Target
.HT
, Tgt_Node
);
298 function Difference
(Left
, Right
: Set
) return Set
is
299 Buckets
: HT_Types
.Buckets_Access
;
303 if Left
'Address = Right
'Address then
307 if Left
.Length
= 0 then
311 if Right
.Length
= 0 then
316 Size
: constant Hash_Type
:= Prime_Numbers
.To_Prime
(Left
.Length
);
318 Buckets
:= new Buckets_Type
(0 .. Size
- 1);
323 Iterate_Left
: declare
324 procedure Process
(L_Node
: Node_Access
);
327 new HT_Ops
.Generic_Iteration
(Process
);
333 procedure Process
(L_Node
: Node_Access
) is
335 if not Is_In
(Right
.HT
, L_Node
) then
337 Src
: Element_Type
renames L_Node
.Element
.all;
338 Indx
: constant Hash_Type
:= Hash
(Src
) mod Buckets
'Length;
339 Bucket
: Node_Access
renames Buckets
(Indx
);
340 Tgt
: Element_Access
:= new Element_Type
'(Src);
342 Bucket := new Node_Type'(Tgt
, Bucket
);
349 Length
:= Length
+ 1;
353 -- Start of processing for Iterate_Left
359 HT_Ops
.Free_Hash_Table
(Buckets
);
363 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
370 function Element
(Position
: Cursor
) return Element_Type
is
372 if Position
.Node
= null then
373 raise Constraint_Error
with "Position cursor of equals No_Element";
376 if Position
.Node
.Element
= null then -- handle dangling reference
377 raise Program_Error
with "Position cursor is bad";
380 pragma Assert
(Vet
(Position
), "bad cursor in function Element");
382 return Position
.Node
.Element
.all;
385 ---------------------
386 -- Equivalent_Sets --
387 ---------------------
389 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
391 return Is_Equivalent
(Left
.HT
, Right
.HT
);
394 -------------------------
395 -- Equivalent_Elements --
396 -------------------------
398 function Equivalent_Elements
(Left
, Right
: Cursor
)
401 if Left
.Node
= null then
402 raise Constraint_Error
with
403 "Left cursor of Equivalent_Elements equals No_Element";
406 if Right
.Node
= null then
407 raise Constraint_Error
with
408 "Right cursor of Equivalent_Elements equals No_Element";
411 if Left
.Node
.Element
= null then
412 raise Program_Error
with
413 "Left cursor of Equivalent_Elements is bad";
416 if Right
.Node
.Element
= null then
417 raise Program_Error
with
418 "Right cursor of Equivalent_Elements is bad";
421 pragma Assert
(Vet
(Left
), "bad Left cursor in Equivalent_Elements");
422 pragma Assert
(Vet
(Right
), "bad Right cursor in Equivalent_Elements");
424 return Equivalent_Elements
425 (Left
.Node
.Element
.all,
426 Right
.Node
.Element
.all);
427 end Equivalent_Elements
;
429 function Equivalent_Elements
(Left
: Cursor
; Right
: Element_Type
)
432 if Left
.Node
= null then
433 raise Constraint_Error
with
434 "Left cursor of Equivalent_Elements equals No_Element";
437 if Left
.Node
.Element
= null then
438 raise Program_Error
with
439 "Left cursor of Equivalent_Elements is bad";
442 pragma Assert
(Vet
(Left
), "bad Left cursor in Equivalent_Elements");
444 return Equivalent_Elements
(Left
.Node
.Element
.all, Right
);
445 end Equivalent_Elements
;
447 function Equivalent_Elements
(Left
: Element_Type
; Right
: Cursor
)
450 if Right
.Node
= null then
451 raise Constraint_Error
with
452 "Right cursor of Equivalent_Elements equals No_Element";
455 if Right
.Node
.Element
= null then
456 raise Program_Error
with
457 "Right cursor of Equivalent_Elements is bad";
460 pragma Assert
(Vet
(Right
), "bad Right cursor in Equivalent_Elements");
462 return Equivalent_Elements
(Left
, Right
.Node
.Element
.all);
463 end Equivalent_Elements
;
465 ---------------------
466 -- Equivalent_Keys --
467 ---------------------
469 function Equivalent_Keys
(Key
: Element_Type
; Node
: Node_Access
)
472 return Equivalent_Elements
(Key
, Node
.Element
.all);
480 (Container
: in out Set
;
485 Element_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Item
, X
);
493 procedure Finalize
(Container
: in out Set
) is
495 HT_Ops
.Finalize
(Container
.HT
);
504 Item
: Element_Type
) return Cursor
506 Node
: constant Node_Access
:= Element_Keys
.Find
(Container
.HT
, Item
);
513 return Cursor
'(Container'Unrestricted_Access, Node);
520 function Find_Equal_Key
521 (R_HT : Hash_Table_Type;
522 L_Node : Node_Access) return Boolean
524 R_Index : constant Hash_Type :=
525 Element_Keys.Index (R_HT, L_Node.Element.all);
527 R_Node : Node_Access := R_HT.Buckets (R_Index);
531 if R_Node = null then
535 if L_Node.Element.all = R_Node.Element.all then
539 R_Node := Next (R_Node);
543 -------------------------
544 -- Find_Equivalent_Key --
545 -------------------------
547 function Find_Equivalent_Key
548 (R_HT : Hash_Table_Type;
549 L_Node : Node_Access) return Boolean
551 R_Index : constant Hash_Type :=
552 Element_Keys.Index (R_HT, L_Node.Element.all);
554 R_Node : Node_Access := R_HT.Buckets (R_Index);
558 if R_Node = null then
562 if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
566 R_Node := Next (R_Node);
568 end Find_Equivalent_Key;
574 function First (Container : Set) return Cursor is
575 Node : constant Node_Access := HT_Ops.First (Container.HT);
582 return Cursor'(Container
'Unrestricted_Access, Node
);
589 procedure Free
(X
: in out Node_Access
) is
590 procedure Deallocate
is
591 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
598 X
.Next
:= X
; -- detect mischief (in Vet)
601 Free_Element
(X
.Element
);
616 function Has_Element
(Position
: Cursor
) return Boolean is
618 pragma Assert
(Vet
(Position
), "bad cursor in Has_Element");
619 return Position
.Node
/= null;
626 function Hash_Node
(Node
: Node_Access
) return Hash_Type
is
628 return Hash
(Node
.Element
.all);
636 (Container
: in out Set
;
637 New_Item
: Element_Type
)
645 Insert
(Container
, New_Item
, Position
, Inserted
);
648 if Container
.HT
.Lock
> 0 then
649 raise Program_Error
with
650 "attempt to tamper with cursors (set is locked)";
653 X
:= Position
.Node
.Element
;
655 Position
.Node
.Element
:= new Element_Type
'(New_Item);
666 (Container : in out Set;
667 New_Item : Element_Type;
668 Position : out Cursor;
669 Inserted : out Boolean)
672 Insert (Container.HT, New_Item, Position.Node, Inserted);
673 Position.Container := Container'Unchecked_Access;
677 (Container : in out Set;
678 New_Item : Element_Type)
684 Insert (Container, New_Item, Position, Inserted);
687 raise Constraint_Error with
688 "attempt to insert element already in set";
693 (HT : in out Hash_Table_Type;
694 New_Item : Element_Type;
695 Node : out Node_Access;
696 Inserted : out Boolean)
698 function New_Node (Next : Node_Access) return Node_Access;
699 pragma Inline (New_Node);
701 procedure Local_Insert is
702 new Element_Keys.Generic_Conditional_Insert (New_Node);
708 function New_Node (Next : Node_Access) return Node_Access is
709 Element : Element_Access := new Element_Type'(New_Item
);
712 return new Node_Type
'(Element, Next);
715 Free_Element (Element);
719 -- Start of processing for Insert
722 if HT_Ops.Capacity (HT) = 0 then
723 HT_Ops.Reserve_Capacity (HT, 1);
726 Local_Insert (HT, New_Item, Node, Inserted);
729 and then HT.Length > HT_Ops.Capacity (HT)
731 HT_Ops.Reserve_Capacity (HT, HT.Length);
739 procedure Intersection
740 (Target : in out Set;
743 Tgt_Node : Node_Access;
746 if Target'Address = Source'Address then
750 if Source.Length = 0 then
755 if Target.HT.Busy > 0 then
756 raise Program_Error with
757 "attempt to tamper with elements (set is busy)";
760 -- TODO: optimize this to use an explicit
761 -- loop instead of an active iterator
762 -- (similar to how a passive iterator is
765 -- Another possibility is to test which
766 -- set is smaller, and iterate over the
769 Tgt_Node := HT_Ops.First (Target.HT);
770 while Tgt_Node /= null loop
771 if Is_In (Source.HT, Tgt_Node) then
772 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
776 X : Node_Access := Tgt_Node;
778 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
779 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
786 function Intersection (Left, Right : Set) return Set is
787 Buckets : HT_Types.Buckets_Access;
791 if Left'Address = Right'Address then
795 Length := Count_Type'Min (Left.Length, Right.Length);
802 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
804 Buckets := new Buckets_Type (0 .. Size - 1);
809 Iterate_Left : declare
810 procedure Process (L_Node : Node_Access);
813 new HT_Ops.Generic_Iteration (Process);
819 procedure Process (L_Node : Node_Access) is
821 if Is_In (Right.HT, L_Node) then
823 Src : Element_Type renames L_Node.Element.all;
825 Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
827 Bucket : Node_Access renames Buckets (Indx);
829 Tgt : Element_Access := new Element_Type'(Src
);
832 Bucket
:= new Node_Type
'(Tgt, Bucket);
839 Length := Length + 1;
843 -- Start of processing for Iterate_Left
849 HT_Ops.Free_Hash_Table (Buckets);
853 return (Controlled with HT => (Buckets, Length, 0, 0));
860 function Is_Empty (Container : Set) return Boolean is
862 return Container.HT.Length = 0;
869 function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
871 return Element_Keys.Find (HT, Key.Element.all) /= null;
880 Of_Set : Set) return Boolean
882 Subset_Node : Node_Access;
885 if Subset'Address = Of_Set'Address then
889 if Subset.Length > Of_Set.Length then
893 -- TODO: rewrite this to loop in the
894 -- style of a passive iterator.
896 Subset_Node := HT_Ops.First (Subset.HT);
897 while Subset_Node /= null loop
898 if not Is_In (Of_Set.HT, Subset_Node) then
902 Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
914 Process : not null access procedure (Position : Cursor))
916 procedure Process_Node (Node : Node_Access);
917 pragma Inline (Process_Node);
920 new HT_Ops.Generic_Iteration (Process_Node);
926 procedure Process_Node (Node : Node_Access) is
928 Process (Cursor'(Container
'Unrestricted_Access, Node
));
931 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.all.HT
;
933 -- Start of processing for Iterate
936 -- TODO: resolve whether HT_Ops.Generic_Iteration should
937 -- manipulate busy bit.
946 function Length
(Container
: Set
) return Count_Type
is
948 return Container
.HT
.Length
;
955 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
957 HT_Ops
.Move
(Target
=> Target
.HT
, Source
=> Source
.HT
);
964 function Next
(Node
: Node_Access
) return Node_Access
is
969 function Next
(Position
: Cursor
) return Cursor
is
971 if Position
.Node
= null then
975 if Position
.Node
.Element
= null then
976 raise Program_Error
with "bad cursor in Next";
979 pragma Assert
(Vet
(Position
), "bad cursor in Next");
982 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
983 Node
: constant Node_Access
:= HT_Ops
.Next
(HT
, Position
.Node
);
990 return Cursor
'(Position.Container, Node);
994 procedure Next (Position : in out Cursor) is
996 Position := Next (Position);
1003 function Overlap (Left, Right : Set) return Boolean is
1004 Left_Node : Node_Access;
1007 if Right.Length = 0 then
1011 if Left'Address = Right'Address then
1015 Left_Node := HT_Ops.First (Left.HT);
1016 while Left_Node /= null loop
1017 if Is_In (Right.HT, Left_Node) then
1021 Left_Node := HT_Ops.Next (Left.HT, Left_Node);
1031 procedure Query_Element
1033 Process : not null access procedure (Element : Element_Type))
1036 if Position.Node = null then
1037 raise Constraint_Error with
1038 "Position cursor of Query_Element equals No_Element";
1041 if Position.Node.Element = null then
1042 raise Program_Error with "bad cursor in Query_Element";
1045 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1048 HT : Hash_Table_Type renames
1049 Position.Container'Unrestricted_Access.all.HT;
1051 B : Natural renames HT.Busy;
1052 L : Natural renames HT.Lock;
1059 Process (Position.Node.Element.all);
1077 (Stream : access Root_Stream_Type'Class;
1078 Container : out Set)
1081 Read_Nodes (Stream, Container.HT);
1085 (Stream : access Root_Stream_Type'Class;
1089 raise Program_Error with "attempt to stream set cursor";
1097 (Stream : access Root_Stream_Type'Class) return Node_Access
1099 X : Element_Access := new Element_Type'(Element_Type
'Input (Stream
));
1102 return new Node_Type
'(X, null);
1114 (Container : in out Set;
1115 New_Item : Element_Type)
1117 Node : constant Node_Access :=
1118 Element_Keys.Find (Container.HT, New_Item);
1124 raise Constraint_Error with
1125 "attempt to replace element not in set";
1128 if Container.HT.Lock > 0 then
1129 raise Program_Error with
1130 "attempt to tamper with cursors (set is locked)";
1135 Node.Element := new Element_Type'(New_Item
);
1140 ---------------------
1141 -- Replace_Element --
1142 ---------------------
1144 procedure Replace_Element
1145 (HT
: in out Hash_Table_Type
;
1147 New_Item
: Element_Type
)
1150 if Equivalent_Elements
(Node
.Element
.all, New_Item
) then
1151 pragma Assert
(Hash
(Node
.Element
.all) = Hash
(New_Item
));
1154 raise Program_Error
with
1155 "attempt to tamper with cursors (set is locked)";
1159 X
: Element_Access
:= Node
.Element
;
1161 Node
.Element
:= new Element_Type
'(New_Item); -- OK if fails
1169 raise Program_Error with
1170 "attempt to tamper with elements (set is busy)";
1173 HT_Ops.Delete_Node_Sans_Free (HT, Node);
1175 Insert_New_Element : declare
1176 function New_Node (Next : Node_Access) return Node_Access;
1177 pragma Inline (New_Node);
1180 new Element_Keys.Generic_Conditional_Insert (New_Node);
1182 ------------------------
1183 -- Insert_New_Element --
1184 ------------------------
1186 function New_Node (Next : Node_Access) return Node_Access is
1188 Node.Element := new Element_Type'(New_Item
); -- OK if fails
1193 Result
: Node_Access
;
1196 X
: Element_Access
:= Node
.Element
;
1198 -- Start of processing for Insert_New_Element
1201 Attempt_Insert
: begin
1206 Inserted
=> Inserted
);
1209 Inserted
:= False; -- Assignment failed
1213 Free_Element
(X
); -- Just propagate if fails
1216 end Insert_New_Element
;
1218 Reinsert_Old_Element
:
1220 function New_Node
(Next
: Node_Access
) return Node_Access
;
1221 pragma Inline
(New_Node
);
1224 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
1230 function New_Node
(Next
: Node_Access
) return Node_Access
is
1236 Result
: Node_Access
;
1239 -- Start of processing for Reinsert_Old_Element
1244 Key
=> Node
.Element
.all,
1246 Inserted
=> Inserted
);
1250 end Reinsert_Old_Element
;
1252 raise Program_Error
with "attempt to replace existing element";
1253 end Replace_Element
;
1255 procedure Replace_Element
1256 (Container
: in out Set
;
1258 New_Item
: Element_Type
)
1261 if Position
.Node
= null then
1262 raise Constraint_Error
with "Position cursor equals No_Element";
1265 if Position
.Node
.Element
= null then
1266 raise Program_Error
with "bad cursor in Replace_Element";
1269 if Position
.Container
/= Container
'Unrestricted_Access then
1270 raise Program_Error
with
1271 "Position cursor designates wrong set";
1274 pragma Assert
(Vet
(Position
), "bad cursor in Replace_Element");
1276 Replace_Element
(Container
.HT
, Position
.Node
, New_Item
);
1277 end Replace_Element
;
1279 ----------------------
1280 -- Reserve_Capacity --
1281 ----------------------
1283 procedure Reserve_Capacity
1284 (Container
: in out Set
;
1285 Capacity
: Count_Type
)
1288 HT_Ops
.Reserve_Capacity
(Container
.HT
, Capacity
);
1289 end Reserve_Capacity
;
1295 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
) is
1300 --------------------------
1301 -- Symmetric_Difference --
1302 --------------------------
1304 procedure Symmetric_Difference
1305 (Target
: in out Set
;
1309 if Target
'Address = Source
'Address then
1314 if Target
.HT
.Busy
> 0 then
1315 raise Program_Error
with
1316 "attempt to tamper with elements (set is busy)";
1320 N
: constant Count_Type
:= Target
.Length
+ Source
.Length
;
1322 if N
> HT_Ops
.Capacity
(Target
.HT
) then
1323 HT_Ops
.Reserve_Capacity
(Target
.HT
, N
);
1327 if Target
.Length
= 0 then
1328 Iterate_Source_When_Empty_Target
: declare
1329 procedure Process
(Src_Node
: Node_Access
);
1331 procedure Iterate
is
1332 new HT_Ops
.Generic_Iteration
(Process
);
1338 procedure Process
(Src_Node
: Node_Access
) is
1339 E
: Element_Type
renames Src_Node
.Element
.all;
1340 B
: Buckets_Type
renames Target
.HT
.Buckets
.all;
1341 J
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
1342 N
: Count_Type
renames Target
.HT
.Length
;
1346 X
: Element_Access
:= new Element_Type
'(E);
1348 B (J) := new Node_Type'(X
, B
(J
));
1358 -- Start of processing for Iterate_Source_When_Empty_Target
1361 Iterate
(Source
.HT
);
1362 end Iterate_Source_When_Empty_Target
;
1365 Iterate_Source
: declare
1366 procedure Process
(Src_Node
: Node_Access
);
1368 procedure Iterate
is
1369 new HT_Ops
.Generic_Iteration
(Process
);
1375 procedure Process
(Src_Node
: Node_Access
) is
1376 E
: Element_Type
renames Src_Node
.Element
.all;
1377 B
: Buckets_Type
renames Target
.HT
.Buckets
.all;
1378 J
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
1379 N
: Count_Type
renames Target
.HT
.Length
;
1382 if B
(J
) = null then
1384 X
: Element_Access
:= new Element_Type
'(E);
1386 B (J) := new Node_Type'(X
, null);
1395 elsif Equivalent_Elements
(E
, B
(J
).Element
.all) then
1397 X
: Node_Access
:= B
(J
);
1399 B
(J
) := B
(J
).Next
;
1406 Prev
: Node_Access
:= B
(J
);
1407 Curr
: Node_Access
:= Prev
.Next
;
1410 while Curr
/= null loop
1411 if Equivalent_Elements
(E
, Curr
.Element
.all) then
1412 Prev
.Next
:= Curr
.Next
;
1423 X
: Element_Access
:= new Element_Type
'(E);
1425 B (J) := new Node_Type'(X
, B
(J
));
1437 -- Start of processing for Iterate_Source
1440 Iterate
(Source
.HT
);
1443 end Symmetric_Difference
;
1445 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
1446 Buckets
: HT_Types
.Buckets_Access
;
1447 Length
: Count_Type
;
1450 if Left
'Address = Right
'Address then
1454 if Right
.Length
= 0 then
1458 if Left
.Length
= 0 then
1463 Size
: constant Hash_Type
:=
1464 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1466 Buckets
:= new Buckets_Type
(0 .. Size
- 1);
1471 Iterate_Left
: declare
1472 procedure Process
(L_Node
: Node_Access
);
1474 procedure Iterate
is
1475 new HT_Ops
.Generic_Iteration
(Process
);
1481 procedure Process
(L_Node
: Node_Access
) is
1483 if not Is_In
(Right
.HT
, L_Node
) then
1485 E
: Element_Type
renames L_Node
.Element
.all;
1486 J
: constant Hash_Type
:= Hash
(E
) mod Buckets
'Length;
1490 X
: Element_Access
:= new Element_Type
'(E);
1492 Buckets (J) := new Node_Type'(X
, Buckets
(J
));
1499 Length
:= Length
+ 1;
1504 -- Start of processing for Iterate_Left
1510 HT_Ops
.Free_Hash_Table
(Buckets
);
1514 Iterate_Right
: declare
1515 procedure Process
(R_Node
: Node_Access
);
1517 procedure Iterate
is
1518 new HT_Ops
.Generic_Iteration
(Process
);
1524 procedure Process
(R_Node
: Node_Access
) is
1526 if not Is_In
(Left
.HT
, R_Node
) then
1528 E
: Element_Type
renames R_Node
.Element
.all;
1529 J
: constant Hash_Type
:= Hash
(E
) mod Buckets
'Length;
1533 X
: Element_Access
:= new Element_Type
'(E);
1535 Buckets (J) := new Node_Type'(X
, Buckets
(J
));
1542 Length
:= Length
+ 1;
1547 -- Start of processing for Iterate_Right
1553 HT_Ops
.Free_Hash_Table
(Buckets
);
1557 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
1558 end Symmetric_Difference
;
1564 function To_Set
(New_Item
: Element_Type
) return Set
is
1565 HT
: Hash_Table_Type
;
1570 Insert
(HT
, New_Item
, Node
, Inserted
);
1571 return Set
'(Controlled with HT);
1579 (Target : in out Set;
1582 procedure Process (Src_Node : Node_Access);
1584 procedure Iterate is
1585 new HT_Ops.Generic_Iteration (Process);
1591 procedure Process (Src_Node : Node_Access) is
1592 Src : Element_Type renames Src_Node.Element.all;
1594 function New_Node (Next : Node_Access) return Node_Access;
1595 pragma Inline (New_Node);
1598 new Element_Keys.Generic_Conditional_Insert (New_Node);
1604 function New_Node (Next : Node_Access) return Node_Access is
1605 Tgt : Element_Access := new Element_Type'(Src
);
1608 return new Node_Type
'(Tgt, Next);
1615 Tgt_Node : Node_Access;
1618 -- Start of processing for Process
1621 Insert (Target.HT, Src, Tgt_Node, Success);
1624 -- Start of processing for Union
1627 if Target'Address = Source'Address then
1631 if Target.HT.Busy > 0 then
1632 raise Program_Error with
1633 "attempt to tamper with elements (set is busy)";
1637 N : constant Count_Type := Target.Length + Source.Length;
1639 if N > HT_Ops.Capacity (Target.HT) then
1640 HT_Ops.Reserve_Capacity (Target.HT, N);
1644 Iterate (Source.HT);
1647 function Union (Left, Right : Set) return Set is
1648 Buckets : HT_Types.Buckets_Access;
1649 Length : Count_Type;
1652 if Left'Address = Right'Address then
1656 if Right.Length = 0 then
1660 if Left.Length = 0 then
1665 Size : constant Hash_Type :=
1666 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1668 Buckets := new Buckets_Type (0 .. Size - 1);
1671 Iterate_Left : declare
1672 procedure Process (L_Node : Node_Access);
1674 procedure Iterate is
1675 new HT_Ops.Generic_Iteration (Process);
1681 procedure Process (L_Node : Node_Access) is
1682 Src : Element_Type renames L_Node.Element.all;
1684 J : constant Hash_Type := Hash (Src) mod Buckets'Length;
1686 Bucket : Node_Access renames Buckets (J);
1688 Tgt : Element_Access := new Element_Type'(Src
);
1691 Bucket
:= new Node_Type
'(Tgt, Bucket);
1698 -- Start of processing for Process
1704 HT_Ops.Free_Hash_Table (Buckets);
1708 Length := Left.Length;
1710 Iterate_Right : declare
1711 procedure Process (Src_Node : Node_Access);
1713 procedure Iterate is
1714 new HT_Ops.Generic_Iteration (Process);
1720 procedure Process (Src_Node : Node_Access) is
1721 Src : Element_Type renames Src_Node.Element.all;
1722 Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
1724 Tgt_Node : Node_Access := Buckets (Idx);
1727 while Tgt_Node /= null loop
1728 if Equivalent_Elements (Src, Tgt_Node.Element.all) then
1731 Tgt_Node := Next (Tgt_Node);
1735 Tgt : Element_Access := new Element_Type'(Src
);
1737 Buckets
(Idx
) := new Node_Type
'(Tgt, Buckets (Idx));
1744 Length := Length + 1;
1747 -- Start of processing for Iterate_Right
1753 HT_Ops.Free_Hash_Table (Buckets);
1757 return (Controlled with HT => (Buckets, Length, 0, 0));
1764 function Vet (Position : Cursor) return Boolean is
1766 if Position.Node = null then
1767 return Position.Container = null;
1770 if Position.Container = null then
1774 if Position.Node.Next = Position.Node then
1778 if Position.Node.Element = null then
1783 HT : Hash_Table_Type renames Position.Container.HT;
1787 if HT.Length = 0 then
1791 if HT.Buckets = null
1792 or else HT.Buckets'Length = 0
1797 X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
1799 for J in 1 .. HT.Length loop
1800 if X = Position.Node then
1808 if X = X.Next then -- to prevent unnecessary looping
1824 (Stream : access Root_Stream_Type'Class;
1828 Write_Nodes (Stream, Container.HT);
1832 (Stream : access Root_Stream_Type'Class;
1836 raise Program_Error with "attempt to stream set cursor";
1843 procedure Write_Node
1844 (Stream : access Root_Stream_Type'Class;
1848 Element_Type'Output (Stream, Node.Element.all);
1851 package body Generic_Keys is
1853 -----------------------
1854 -- Local Subprograms --
1855 -----------------------
1857 function Equivalent_Key_Node
1859 Node : Node_Access) return Boolean;
1860 pragma Inline (Equivalent_Key_Node);
1862 --------------------------
1863 -- Local Instantiations --
1864 --------------------------
1867 new Hash_Tables.Generic_Keys
1868 (HT_Types => HT_Types,
1870 Set_Next => Set_Next,
1871 Key_Type => Key_Type,
1873 Equivalent_Keys => Equivalent_Key_Node);
1881 Key : Key_Type) return Boolean
1884 return Find (Container, Key) /= No_Element;
1892 (Container : in out Set;
1898 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1901 raise Constraint_Error with "key not in map";
1913 Key : Key_Type) return Element_Type
1915 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1919 raise Constraint_Error with "key not in map";
1922 return Node.Element.all;
1925 -------------------------
1926 -- Equivalent_Key_Node --
1927 -------------------------
1929 function Equivalent_Key_Node
1931 Node : Node_Access) return Boolean is
1933 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
1934 end Equivalent_Key_Node;
1941 (Container : in out Set;
1946 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1956 Key : Key_Type) return Cursor
1958 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1965 return Cursor'(Container
'Unrestricted_Access, Node
);
1972 function Key
(Position
: Cursor
) return Key_Type
is
1974 if Position
.Node
= null then
1975 raise Constraint_Error
with
1976 "Position cursor equals No_Element";
1979 if Position
.Node
.Element
= null then
1980 raise Program_Error
with "Position cursor is bad";
1983 pragma Assert
(Vet
(Position
), "bad cursor in function Key");
1985 return Key
(Position
.Node
.Element
.all);
1993 (Container
: in out Set
;
1995 New_Item
: Element_Type
)
1997 Node
: constant Node_Access
:=
1998 Key_Keys
.Find
(Container
.HT
, Key
);
2002 raise Constraint_Error
with
2003 "attempt to replace key not in set";
2006 Replace_Element
(Container
.HT
, Node
, New_Item
);
2009 procedure Update_Element_Preserving_Key
2010 (Container
: in out Set
;
2012 Process
: not null access
2013 procedure (Element
: in out Element_Type
))
2015 HT
: Hash_Table_Type
renames Container
.HT
;
2019 if Position
.Node
= null then
2020 raise Constraint_Error
with
2021 "Position cursor equals No_Element";
2024 if Position
.Node
.Element
= null
2025 or else Position
.Node
.Next
= Position
.Node
2027 raise Program_Error
with "Position cursor is bad";
2030 if Position
.Container
/= Container
'Unrestricted_Access then
2031 raise Program_Error
with
2032 "Position cursor designates wrong set";
2035 if HT
.Buckets
= null
2036 or else HT
.Buckets
'Length = 0
2037 or else HT
.Length
= 0
2039 raise Program_Error
with "Position cursor is bad (set is empty)";
2044 "bad cursor in Update_Element_Preserving_Key");
2046 Indx
:= HT_Ops
.Index
(HT
, Position
.Node
);
2049 E
: Element_Type
renames Position
.Node
.Element
.all;
2050 K
: constant Key_Type
:= Key
(E
);
2052 B
: Natural renames HT
.Busy
;
2053 L
: Natural renames HT
.Lock
;
2071 if Equivalent_Keys
(K
, Key
(E
)) then
2072 pragma Assert
(Hash
(K
) = Hash
(E
));
2077 if HT
.Buckets
(Indx
) = Position
.Node
then
2078 HT
.Buckets
(Indx
) := Position
.Node
.Next
;
2082 Prev
: Node_Access
:= HT
.Buckets
(Indx
);
2085 while Prev
.Next
/= Position
.Node
loop
2089 raise Program_Error
with
2090 "Position cursor is bad (node not found)";
2094 Prev
.Next
:= Position
.Node
.Next
;
2098 HT
.Length
:= HT
.Length
- 1;
2101 X
: Node_Access
:= Position
.Node
;
2107 raise Program_Error
with "key was modified";
2108 end Update_Element_Preserving_Key
;
2112 end Ada
.Containers
.Indefinite_Hashed_Sets
;