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-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Unchecked_Deallocation
;
32 with Ada
.Containers
.Hash_Tables
.Generic_Operations
;
33 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Operations
);
35 with Ada
.Containers
.Hash_Tables
.Generic_Keys
;
36 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Keys
);
38 with Ada
.Containers
.Prime_Numbers
;
40 with System
; use type System
.Address
;
42 package body Ada
.Containers
.Hashed_Sets
is
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
48 procedure Assign
(Node
: Node_Access
; Item
: Element_Type
);
49 pragma Inline
(Assign
);
51 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
52 pragma Inline
(Copy_Node
);
54 function Equivalent_Keys
56 Node
: Node_Access
) return Boolean;
57 pragma Inline
(Equivalent_Keys
);
59 function Find_Equal_Key
60 (R_HT
: Hash_Table_Type
;
61 L_Node
: Node_Access
) return Boolean;
63 function Find_Equivalent_Key
64 (R_HT
: Hash_Table_Type
;
65 L_Node
: Node_Access
) return Boolean;
67 procedure Free
(X
: in out Node_Access
);
69 function Hash_Node
(Node
: Node_Access
) return Hash_Type
;
70 pragma Inline
(Hash_Node
);
73 (HT
: in out Hash_Table_Type
;
74 New_Item
: Element_Type
;
75 Node
: out Node_Access
;
76 Inserted
: out Boolean);
79 (HT
: aliased in out Hash_Table_Type
;
80 Key
: Node_Access
) return Boolean;
81 pragma Inline
(Is_In
);
83 function Next
(Node
: Node_Access
) return Node_Access
;
86 function Read_Node
(Stream
: not null access Root_Stream_Type
'Class)
88 pragma Inline
(Read_Node
);
90 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
);
91 pragma Inline
(Set_Next
);
93 function Vet
(Position
: Cursor
) return Boolean;
96 (Stream
: not null access Root_Stream_Type
'Class;
98 pragma Inline
(Write_Node
);
100 --------------------------
101 -- Local Instantiations --
102 --------------------------
104 package HT_Ops
is new Hash_Tables
.Generic_Operations
105 (HT_Types
=> HT_Types
,
106 Hash_Node
=> Hash_Node
,
108 Set_Next
=> Set_Next
,
109 Copy_Node
=> Copy_Node
,
112 package Element_Keys
is new Hash_Tables
.Generic_Keys
113 (HT_Types
=> HT_Types
,
115 Set_Next
=> Set_Next
,
116 Key_Type
=> Element_Type
,
118 Equivalent_Keys
=> Equivalent_Keys
);
121 new HT_Ops
.Generic_Equal
(Find_Equal_Key
);
123 function Is_Equivalent
is
124 new HT_Ops
.Generic_Equal
(Find_Equivalent_Key
);
126 procedure Read_Nodes
is
127 new HT_Ops
.Generic_Read
(Read_Node
);
129 procedure Replace_Element
is
130 new Element_Keys
.Generic_Replace_Element
(Hash_Node
, Assign
);
132 procedure Write_Nodes
is
133 new HT_Ops
.Generic_Write
(Write_Node
);
139 function "=" (Left
, Right
: Set
) return Boolean is
141 return Is_Equal
(Left
.HT
, Right
.HT
);
148 procedure Adjust
(Container
: in out Set
) is
150 HT_Ops
.Adjust
(Container
.HT
);
153 procedure Adjust
(Control
: in out Reference_Control_Type
) is
155 if Control
.Container
/= null then
157 HT
: Hash_Table_Type
renames Control
.Container
.all.HT
;
158 B
: Natural renames HT
.Busy
;
159 L
: Natural renames HT
.Lock
;
171 procedure Assign
(Node
: Node_Access
; Item
: Element_Type
) is
173 Node
.Element
:= Item
;
176 procedure Assign
(Target
: in out Set
; Source
: Set
) is
178 if Target
'Address = Source
'Address then
183 Target
.Union
(Source
);
190 function Capacity
(Container
: Set
) return Count_Type
is
192 return HT_Ops
.Capacity
(Container
.HT
);
199 procedure Clear
(Container
: in out Set
) is
201 HT_Ops
.Clear
(Container
.HT
);
204 ------------------------
205 -- Constant_Reference --
206 ------------------------
208 function Constant_Reference
209 (Container
: aliased Set
;
210 Position
: Cursor
) return Constant_Reference_Type
213 if Position
.Container
= null then
214 raise Constraint_Error
with "Position cursor has no element";
217 if Position
.Container
/= Container
'Unrestricted_Access then
218 raise Program_Error
with
219 "Position cursor designates wrong container";
222 pragma Assert
(Vet
(Position
), "bad cursor in Constant_Reference");
225 HT
: Hash_Table_Type
renames Position
.Container
.all.HT
;
226 B
: Natural renames HT
.Busy
;
227 L
: Natural renames HT
.Lock
;
229 return R
: constant Constant_Reference_Type
:=
230 (Element
=> Position
.Node
.Element
'Access,
231 Control
=> (Controlled
with Container
'Unrestricted_Access))
237 end Constant_Reference
;
243 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean is
245 return Find
(Container
, Item
) /= No_Element
;
254 Capacity
: Count_Type
:= 0) return Set
262 elsif Capacity
>= Source
.Length
then
267 with "Requested capacity is less than Source length";
270 return Target
: Set
do
271 Target
.Reserve_Capacity
(C
);
272 Target
.Assign
(Source
);
280 function Copy_Node
(Source
: Node_Access
) return Node_Access
is
282 return new Node_Type
'(Element => Source.Element, Next => null);
290 (Container : in out Set;
296 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
299 raise Constraint_Error with "attempt to delete element not in set";
306 (Container : in out Set;
307 Position : in out Cursor)
310 if Position.Node = null then
311 raise Constraint_Error with "Position cursor equals No_Element";
314 if Position.Container /= Container'Unrestricted_Access then
315 raise Program_Error with "Position cursor designates wrong set";
318 if Container.HT.Busy > 0 then
319 raise Program_Error with
320 "attempt to tamper with cursors (set is busy)";
323 pragma Assert (Vet (Position), "bad cursor in Delete");
325 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
327 Free (Position.Node);
328 Position.Container := null;
336 (Target : in out Set;
339 Tgt_Node : Node_Access;
340 Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT;
343 if Target'Address = Source'Address then
348 if Src_HT.Length = 0 then
352 if Target.HT.Busy > 0 then
353 raise Program_Error with
354 "attempt to tamper with cursors (set is busy)";
357 if Src_HT.Length < Target.HT.Length then
359 Src_Node : Node_Access;
362 Src_Node := HT_Ops.First (Src_HT);
363 while Src_Node /= null loop
364 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element);
366 if Tgt_Node /= null then
367 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
371 Src_Node := HT_Ops.Next (Src_HT, Src_Node);
376 Tgt_Node := HT_Ops.First (Target.HT);
377 while Tgt_Node /= null loop
378 if Is_In (Src_HT, Tgt_Node) then
380 X : Node_Access := Tgt_Node;
382 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
383 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
388 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
394 function Difference (Left, Right : Set) return Set is
395 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
396 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
397 Buckets : HT_Types.Buckets_Access;
401 if Left'Address = Right'Address then
405 if Left_HT.Length = 0 then
409 if Right_HT.Length = 0 then
414 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
416 Buckets := HT_Ops.New_Buckets (Length => Size);
421 Iterate_Left : declare
422 procedure Process (L_Node : Node_Access);
425 new HT_Ops.Generic_Iteration (Process);
431 procedure Process (L_Node : Node_Access) is
433 if not Is_In (Right_HT, L_Node) then
435 -- Per AI05-0022, the container implementation is required
436 -- to detect element tampering by a generic actual
437 -- subprogram, hence the use of Checked_Index instead of a
438 -- simple invocation of generic formal Hash.
440 J : constant Hash_Type :=
441 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
443 Bucket : Node_Access renames Buckets (J);
446 Bucket := new Node_Type'(L_Node
.Element
, Bucket
);
449 Length
:= Length
+ 1;
453 -- Start of processing for Iterate_Left
459 HT_Ops
.Free_Hash_Table
(Buckets
);
463 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
470 function Element
(Position
: Cursor
) return Element_Type
is
472 if Position
.Node
= null then
473 raise Constraint_Error
with "Position cursor equals No_Element";
476 pragma Assert
(Vet
(Position
), "bad cursor in function Element");
478 return Position
.Node
.Element
;
481 ---------------------
482 -- Equivalent_Sets --
483 ---------------------
485 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
487 return Is_Equivalent
(Left
.HT
, Right
.HT
);
490 -------------------------
491 -- Equivalent_Elements --
492 -------------------------
494 function Equivalent_Elements
(Left
, Right
: Cursor
)
497 if Left
.Node
= null then
498 raise Constraint_Error
with
499 "Left cursor of Equivalent_Elements equals No_Element";
502 if Right
.Node
= null then
503 raise Constraint_Error
with
504 "Right cursor of Equivalent_Elements equals No_Element";
507 pragma Assert
(Vet
(Left
), "bad Left cursor in Equivalent_Elements");
508 pragma Assert
(Vet
(Right
), "bad Right cursor in Equivalent_Elements");
510 -- AI05-0022 requires that a container implementation detect element
511 -- tampering by a generic actual subprogram. However, the following case
512 -- falls outside the scope of that AI. Randy Brukardt explained on the
513 -- ARG list on 2013/02/07 that:
516 -- But for an operation like "<" [the ordered set analog of
517 -- Equivalent_Elements], there is no need to "dereference" a cursor
518 -- after the call to the generic formal parameter function, so nothing
519 -- bad could happen if tampering is undetected. And the operation can
520 -- safely return a result without a problem even if an element is
521 -- deleted from the container.
524 return Equivalent_Elements
(Left
.Node
.Element
, Right
.Node
.Element
);
525 end Equivalent_Elements
;
527 function Equivalent_Elements
(Left
: Cursor
; Right
: Element_Type
)
530 if Left
.Node
= null then
531 raise Constraint_Error
with
532 "Left cursor of Equivalent_Elements equals No_Element";
535 pragma Assert
(Vet
(Left
), "Left cursor in Equivalent_Elements is bad");
537 return Equivalent_Elements
(Left
.Node
.Element
, Right
);
538 end Equivalent_Elements
;
540 function Equivalent_Elements
(Left
: Element_Type
; Right
: Cursor
)
543 if Right
.Node
= null then
544 raise Constraint_Error
with
545 "Right cursor of Equivalent_Elements equals No_Element";
550 "Right cursor of Equivalent_Elements is bad");
552 return Equivalent_Elements
(Left
, Right
.Node
.Element
);
553 end Equivalent_Elements
;
555 ---------------------
556 -- Equivalent_Keys --
557 ---------------------
559 function Equivalent_Keys
(Key
: Element_Type
; Node
: Node_Access
)
562 return Equivalent_Elements
(Key
, Node
.Element
);
570 (Container
: in out Set
;
575 Element_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Item
, X
);
583 procedure Finalize
(Container
: in out Set
) is
585 HT_Ops
.Finalize
(Container
.HT
);
588 procedure Finalize
(Control
: in out Reference_Control_Type
) is
590 if Control
.Container
/= null then
592 HT
: Hash_Table_Type
renames Control
.Container
.all.HT
;
593 B
: Natural renames HT
.Busy
;
594 L
: Natural renames HT
.Lock
;
600 Control
.Container
:= null;
610 Item
: Element_Type
) return Cursor
612 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.HT
;
613 Node
: constant Node_Access
:= Element_Keys
.Find
(HT
, Item
);
620 return Cursor
'(Container'Unrestricted_Access, Node);
627 function Find_Equal_Key
628 (R_HT : Hash_Table_Type;
629 L_Node : Node_Access) return Boolean
631 R_Index : constant Hash_Type :=
632 Element_Keys.Index (R_HT, L_Node.Element);
634 R_Node : Node_Access := R_HT.Buckets (R_Index);
638 if R_Node = null then
642 if L_Node.Element = R_Node.Element then
646 R_Node := Next (R_Node);
650 -------------------------
651 -- Find_Equivalent_Key --
652 -------------------------
654 function Find_Equivalent_Key
655 (R_HT : Hash_Table_Type;
656 L_Node : Node_Access) return Boolean
658 R_Index : constant Hash_Type :=
659 Element_Keys.Index (R_HT, L_Node.Element);
661 R_Node : Node_Access := R_HT.Buckets (R_Index);
665 if R_Node = null then
669 if Equivalent_Elements (L_Node.Element, R_Node.Element) then
673 R_Node := Next (R_Node);
675 end Find_Equivalent_Key;
681 function First (Container : Set) return Cursor is
682 Node : constant Node_Access := HT_Ops.First (Container.HT);
689 return Cursor'(Container
'Unrestricted_Access, Node
);
692 function First
(Object
: Iterator
) return Cursor
is
694 return Object
.Container
.First
;
701 procedure Free
(X
: in out Node_Access
) is
702 procedure Deallocate
is
703 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
707 X
.Next
:= X
; -- detect mischief (in Vet)
716 function Has_Element
(Position
: Cursor
) return Boolean is
718 pragma Assert
(Vet
(Position
), "bad cursor in Has_Element");
719 return Position
.Node
/= null;
726 function Hash_Node
(Node
: Node_Access
) return Hash_Type
is
728 return Hash
(Node
.Element
);
736 (Container
: in out Set
;
737 New_Item
: Element_Type
)
743 Insert
(Container
, New_Item
, Position
, Inserted
);
746 if Container
.HT
.Lock
> 0 then
747 raise Program_Error
with
748 "attempt to tamper with elements (set is locked)";
751 Position
.Node
.Element
:= New_Item
;
760 (Container
: in out Set
;
761 New_Item
: Element_Type
;
762 Position
: out Cursor
;
763 Inserted
: out Boolean)
766 Insert
(Container
.HT
, New_Item
, Position
.Node
, Inserted
);
767 Position
.Container
:= Container
'Unchecked_Access;
771 (Container
: in out Set
;
772 New_Item
: Element_Type
)
775 pragma Unreferenced
(Position
);
780 Insert
(Container
, New_Item
, Position
, Inserted
);
783 raise Constraint_Error
with
784 "attempt to insert element already in set";
789 (HT
: in out Hash_Table_Type
;
790 New_Item
: Element_Type
;
791 Node
: out Node_Access
;
792 Inserted
: out Boolean)
794 function New_Node
(Next
: Node_Access
) return Node_Access
;
795 pragma Inline
(New_Node
);
797 procedure Local_Insert
is
798 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
804 function New_Node
(Next
: Node_Access
) return Node_Access
is
806 return new Node_Type
'(New_Item, Next);
809 -- Start of processing for Insert
812 if HT_Ops.Capacity (HT) = 0 then
813 HT_Ops.Reserve_Capacity (HT, 1);
816 Local_Insert (HT, New_Item, Node, Inserted);
819 and then HT.Length > HT_Ops.Capacity (HT)
821 HT_Ops.Reserve_Capacity (HT, HT.Length);
829 procedure Intersection
830 (Target : in out Set;
833 Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT;
834 Tgt_Node : Node_Access;
837 if Target'Address = Source'Address then
841 if Source.HT.Length = 0 then
846 if Target.HT.Busy > 0 then
847 raise Program_Error with
848 "attempt to tamper with cursors (set is busy)";
851 Tgt_Node := HT_Ops.First (Target.HT);
852 while Tgt_Node /= null loop
853 if Is_In (Src_HT, Tgt_Node) then
854 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
858 X : Node_Access := Tgt_Node;
860 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
861 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
868 function Intersection (Left, Right : Set) return Set is
869 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
870 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
871 Buckets : HT_Types.Buckets_Access;
875 if Left'Address = Right'Address then
879 Length := Count_Type'Min (Left.Length, Right.Length);
886 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
888 Buckets := HT_Ops.New_Buckets (Length => Size);
893 Iterate_Left : declare
894 procedure Process (L_Node : Node_Access);
897 new HT_Ops.Generic_Iteration (Process);
903 procedure Process (L_Node : Node_Access) is
905 if Is_In (Right_HT, L_Node) then
907 -- Per AI05-0022, the container implementation is required
908 -- to detect element tampering by a generic actual
909 -- subprogram, hence the use of Checked_Index instead of a
910 -- simple invocation of generic formal Hash.
912 J : constant Hash_Type :=
913 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
915 Bucket : Node_Access renames Buckets (J);
918 Bucket := new Node_Type'(L_Node
.Element
, Bucket
);
921 Length
:= Length
+ 1;
925 -- Start of processing for Iterate_Left
931 HT_Ops
.Free_Hash_Table
(Buckets
);
935 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
942 function Is_Empty
(Container
: Set
) return Boolean is
944 return Container
.HT
.Length
= 0;
952 (HT
: aliased in out Hash_Table_Type
;
953 Key
: Node_Access
) return Boolean
956 return Element_Keys
.Find
(HT
, Key
.Element
) /= null;
963 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
964 Subset_HT
: Hash_Table_Type
renames Subset
'Unrestricted_Access.HT
;
965 Of_Set_HT
: Hash_Table_Type
renames Of_Set
'Unrestricted_Access.HT
;
966 Subset_Node
: Node_Access
;
969 if Subset
'Address = Of_Set
'Address then
973 if Subset
.Length
> Of_Set
.Length
then
977 Subset_Node
:= HT_Ops
.First
(Subset_HT
);
978 while Subset_Node
/= null loop
979 if not Is_In
(Of_Set_HT
, Subset_Node
) then
982 Subset_Node
:= HT_Ops
.Next
(Subset_HT
, Subset_Node
);
994 Process
: not null access procedure (Position
: Cursor
))
996 procedure Process_Node
(Node
: Node_Access
);
997 pragma Inline
(Process_Node
);
1000 new HT_Ops
.Generic_Iteration
(Process_Node
);
1006 procedure Process_Node
(Node
: Node_Access
) is
1008 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1011 B : Natural renames Container'Unrestricted_Access.HT.Busy;
1013 -- Start of processing for Iterate
1019 Iterate (Container.HT);
1030 (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class
1033 return Iterator'(Container
=> Container
'Unrestricted_Access);
1040 function Length
(Container
: Set
) return Count_Type
is
1042 return Container
.HT
.Length
;
1049 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1051 HT_Ops
.Move
(Target
=> Target
.HT
, Source
=> Source
.HT
);
1058 function Next
(Node
: Node_Access
) return Node_Access
is
1063 function Next
(Position
: Cursor
) return Cursor
is
1065 if Position
.Node
= null then
1069 pragma Assert
(Vet
(Position
), "bad cursor in Next");
1072 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
1073 Node
: constant Node_Access
:= HT_Ops
.Next
(HT
, Position
.Node
);
1080 return Cursor
'(Position.Container, Node);
1084 procedure Next (Position : in out Cursor) is
1086 Position := Next (Position);
1091 Position : Cursor) return Cursor
1094 if Position.Container = null then
1098 if Position.Container /= Object.Container then
1099 raise Program_Error with
1100 "Position cursor of Next designates wrong set";
1103 return Next (Position);
1110 function Overlap (Left, Right : Set) return Boolean is
1111 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
1112 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
1113 Left_Node : Node_Access;
1116 if Right.Length = 0 then
1120 if Left'Address = Right'Address then
1124 Left_Node := HT_Ops.First (Left_HT);
1125 while Left_Node /= null loop
1126 if Is_In (Right_HT, Left_Node) then
1129 Left_Node := HT_Ops.Next (Left_HT, Left_Node);
1139 procedure Query_Element
1141 Process : not null access procedure (Element : Element_Type))
1144 if Position.Node = null then
1145 raise Constraint_Error with
1146 "Position cursor of Query_Element equals No_Element";
1149 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1152 HT : Hash_Table_Type renames Position.Container.HT;
1154 B : Natural renames HT.Busy;
1155 L : Natural renames HT.Lock;
1162 Process (Position.Node.Element);
1180 (Stream : not null access Root_Stream_Type'Class;
1181 Container : out Set)
1184 Read_Nodes (Stream, Container.HT);
1188 (Stream : not null access Root_Stream_Type'Class;
1192 raise Program_Error with "attempt to stream set cursor";
1196 (Stream : not null access Root_Stream_Type'Class;
1197 Item : out Constant_Reference_Type)
1200 raise Program_Error with "attempt to stream reference";
1207 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1210 Node : Node_Access := new Node_Type;
1212 Element_Type'Read (Stream, Node.Element);
1225 (Container : in out Set;
1226 New_Item : Element_Type)
1228 Node : constant Node_Access :=
1229 Element_Keys.Find (Container.HT, New_Item);
1233 raise Constraint_Error with
1234 "attempt to replace element not in set";
1237 if Container.HT.Lock > 0 then
1238 raise Program_Error with
1239 "attempt to tamper with elements (set is locked)";
1242 Node.Element := New_Item;
1245 procedure Replace_Element
1246 (Container : in out Set;
1248 New_Item : Element_Type)
1251 if Position.Node = null then
1252 raise Constraint_Error with
1253 "Position cursor equals No_Element";
1256 if Position.Container /= Container'Unrestricted_Access then
1257 raise Program_Error with
1258 "Position cursor designates wrong set";
1261 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1263 Replace_Element (Container.HT, Position.Node, New_Item);
1264 end Replace_Element;
1266 ----------------------
1267 -- Reserve_Capacity --
1268 ----------------------
1270 procedure Reserve_Capacity
1271 (Container : in out Set;
1272 Capacity : Count_Type)
1275 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1276 end Reserve_Capacity;
1282 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1287 --------------------------
1288 -- Symmetric_Difference --
1289 --------------------------
1291 procedure Symmetric_Difference
1292 (Target : in out Set;
1295 Tgt_HT : Hash_Table_Type renames Target.HT;
1296 Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all;
1298 -- Per AI05-0022, the container implementation is required to detect
1299 -- element tampering by a generic actual subprogram.
1301 TB : Natural renames Tgt_HT.Busy;
1302 TL : Natural renames Tgt_HT.Lock;
1304 SB : Natural renames Src_HT.Busy;
1305 SL : Natural renames Src_HT.Lock;
1308 if Target'Address = Source'Address then
1314 raise Program_Error with
1315 "attempt to tamper with cursors (set is busy)";
1319 N : constant Count_Type := Target.Length + Source.Length;
1321 if N > HT_Ops.Capacity (Tgt_HT) then
1322 HT_Ops.Reserve_Capacity (Tgt_HT, N);
1326 if Target.Length = 0 then
1327 Iterate_Source_When_Empty_Target : declare
1328 procedure Process (Src_Node : Node_Access);
1330 procedure Iterate is
1331 new HT_Ops.Generic_Iteration (Process);
1337 procedure Process (Src_Node : Node_Access) is
1338 E : Element_Type renames Src_Node.Element;
1339 B : Buckets_Type renames Tgt_HT.Buckets.all;
1340 J : constant Hash_Type := Hash (E) mod B'Length;
1341 N : Count_Type renames Tgt_HT.Length;
1344 B (J) := new Node_Type'(E
, B
(J
));
1348 -- Start of processing for Iterate_Source_When_Empty_Target
1374 end Iterate_Source_When_Empty_Target
;
1377 Iterate_Source
: declare
1378 procedure Process
(Src_Node
: Node_Access
);
1380 procedure Iterate
is
1381 new HT_Ops
.Generic_Iteration
(Process
);
1387 procedure Process
(Src_Node
: Node_Access
) is
1388 E
: Element_Type
renames Src_Node
.Element
;
1389 B
: Buckets_Type
renames Tgt_HT
.Buckets
.all;
1390 J
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
1391 N
: Count_Type
renames Tgt_HT
.Length
;
1394 if B
(J
) = null then
1395 B
(J
) := new Node_Type
'(E, null);
1398 elsif Equivalent_Elements (E, B (J).Element) then
1400 X : Node_Access := B (J);
1402 B (J) := B (J).Next;
1409 Prev : Node_Access := B (J);
1410 Curr : Node_Access := Prev.Next;
1413 while Curr /= null loop
1414 if Equivalent_Elements (E, Curr.Element) then
1415 Prev.Next := Curr.Next;
1425 B (J) := new Node_Type'(E
, B
(J
));
1431 -- Start of processing for Iterate_Source
1459 end Symmetric_Difference
;
1461 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
1462 Left_HT
: Hash_Table_Type
renames Left
'Unrestricted_Access.HT
;
1463 Right_HT
: Hash_Table_Type
renames Right
'Unrestricted_Access.HT
;
1464 Buckets
: HT_Types
.Buckets_Access
;
1465 Length
: Count_Type
;
1468 if Left
'Address = Right
'Address then
1472 if Right
.Length
= 0 then
1476 if Left
.Length
= 0 then
1481 Size
: constant Hash_Type
:=
1482 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1484 Buckets
:= HT_Ops
.New_Buckets
(Length
=> Size
);
1489 Iterate_Left
: declare
1490 procedure Process
(L_Node
: Node_Access
);
1492 procedure Iterate
is
1493 new HT_Ops
.Generic_Iteration
(Process
);
1499 procedure Process
(L_Node
: Node_Access
) is
1501 if not Is_In
(Right_HT
, L_Node
) then
1503 E
: Element_Type
renames L_Node
.Element
;
1505 -- Per AI05-0022, the container implementation is required
1506 -- to detect element tampering by a generic actual
1507 -- subprogram, hence the use of Checked_Index instead of a
1508 -- simple invocation of generic formal Hash.
1510 J
: constant Hash_Type
:=
1511 HT_Ops
.Checked_Index
(Left_HT
, Buckets
.all, L_Node
);
1514 Buckets
(J
) := new Node_Type
'(E, Buckets (J));
1515 Length := Length + 1;
1520 -- Start of processing for Iterate_Left
1527 HT_Ops.Free_Hash_Table (Buckets);
1531 Iterate_Right : declare
1532 procedure Process (R_Node : Node_Access);
1534 procedure Iterate is
1535 new HT_Ops.Generic_Iteration (Process);
1541 procedure Process (R_Node : Node_Access) is
1543 if not Is_In (Left_HT, R_Node) then
1545 E : Element_Type renames R_Node.Element;
1547 -- Per AI05-0022, the container implementation is required
1548 -- to detect element tampering by a generic actual
1549 -- subprogram, hence the use of Checked_Index instead of a
1550 -- simple invocation of generic formal Hash.
1552 J : constant Hash_Type :=
1553 HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node);
1556 Buckets (J) := new Node_Type'(E
, Buckets
(J
));
1557 Length
:= Length
+ 1;
1562 -- Start of processing for Iterate_Right
1569 HT_Ops
.Free_Hash_Table
(Buckets
);
1573 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
1574 end Symmetric_Difference
;
1580 function To_Set
(New_Item
: Element_Type
) return Set
is
1581 HT
: Hash_Table_Type
;
1585 pragma Unreferenced
(Node
, Inserted
);
1588 Insert
(HT
, New_Item
, Node
, Inserted
);
1589 return Set
'(Controlled with HT);
1597 (Target : in out Set;
1600 procedure Process (Src_Node : Node_Access);
1602 procedure Iterate is
1603 new HT_Ops.Generic_Iteration (Process);
1609 procedure Process (Src_Node : Node_Access) is
1610 function New_Node (Next : Node_Access) return Node_Access;
1611 pragma Inline (New_Node);
1614 new Element_Keys.Generic_Conditional_Insert (New_Node);
1620 function New_Node (Next : Node_Access) return Node_Access is
1621 Node : constant Node_Access :=
1622 new Node_Type'(Src_Node
.Element
, Next
);
1627 Tgt_Node
: Node_Access
;
1629 pragma Unreferenced
(Tgt_Node
, Success
);
1631 -- Start of processing for Process
1634 Insert
(Target
.HT
, Src_Node
.Element
, Tgt_Node
, Success
);
1637 -- Start of processing for Union
1640 if Target
'Address = Source
'Address then
1644 if Target
.HT
.Busy
> 0 then
1645 raise Program_Error
with
1646 "attempt to tamper with cursors (set is busy)";
1650 N
: constant Count_Type
:= Target
.Length
+ Source
.Length
;
1652 if N
> HT_Ops
.Capacity
(Target
.HT
) then
1653 HT_Ops
.Reserve_Capacity
(Target
.HT
, N
);
1657 Iterate
(Source
.HT
);
1660 function Union
(Left
, Right
: Set
) return Set
is
1661 Left_HT
: Hash_Table_Type
renames Left
.HT
'Unrestricted_Access.all;
1662 Right_HT
: Hash_Table_Type
renames Right
.HT
'Unrestricted_Access.all;
1663 Buckets
: HT_Types
.Buckets_Access
;
1664 Length
: Count_Type
;
1667 if Left
'Address = Right
'Address then
1671 if Right
.Length
= 0 then
1675 if Left
.Length
= 0 then
1680 Size
: constant Hash_Type
:=
1681 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1683 Buckets
:= HT_Ops
.New_Buckets
(Length
=> Size
);
1686 Iterate_Left
: declare
1687 procedure Process
(L_Node
: Node_Access
);
1689 procedure Iterate
is
1690 new HT_Ops
.Generic_Iteration
(Process
);
1696 procedure Process
(L_Node
: Node_Access
) is
1697 J
: constant Hash_Type
:=
1698 Hash
(L_Node
.Element
) mod Buckets
'Length;
1701 Buckets
(J
) := new Node_Type
'(L_Node.Element, Buckets (J));
1704 -- Per AI05-0022, the container implementation is required to detect
1705 -- element tampering by a generic actual subprogram, hence the use of
1706 -- Checked_Index instead of a simple invocation of generic formal
1709 B : Integer renames Left_HT.Busy;
1710 L : Integer renames Left_HT.Lock;
1712 -- Start of processing for Iterate_Left
1728 HT_Ops.Free_Hash_Table (Buckets);
1732 Length := Left.Length;
1734 Iterate_Right : declare
1735 procedure Process (Src_Node : Node_Access);
1737 procedure Iterate is
1738 new HT_Ops.Generic_Iteration (Process);
1744 procedure Process (Src_Node : Node_Access) is
1745 J : constant Hash_Type :=
1746 Hash (Src_Node.Element) mod Buckets'Length;
1748 Tgt_Node : Node_Access := Buckets (J);
1751 while Tgt_Node /= null loop
1752 if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1756 Tgt_Node := Next (Tgt_Node);
1759 Buckets (J) := new Node_Type'(Src_Node
.Element
, Buckets
(J
));
1760 Length
:= Length
+ 1;
1763 -- Per AI05-0022, the container implementation is required to detect
1764 -- element tampering by a generic actual subprogram, hence the use of
1765 -- Checked_Index instead of a simple invocation of generic formal
1768 LB
: Integer renames Left_HT
.Busy
;
1769 LL
: Integer renames Left_HT
.Lock
;
1771 RB
: Integer renames Right_HT
.Busy
;
1772 RL
: Integer renames Right_HT
.Lock
;
1774 -- Start of processing for Iterate_Right
1799 HT_Ops
.Free_Hash_Table
(Buckets
);
1803 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
1810 function Vet
(Position
: Cursor
) return Boolean is
1812 if Position
.Node
= null then
1813 return Position
.Container
= null;
1816 if Position
.Container
= null then
1820 if Position
.Node
.Next
= Position
.Node
then
1825 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
1829 if HT
.Length
= 0 then
1833 if HT
.Buckets
= null
1834 or else HT
.Buckets
'Length = 0
1839 X
:= HT
.Buckets
(Element_Keys
.Checked_Index
1841 Position
.Node
.Element
));
1843 for J
in 1 .. HT
.Length
loop
1844 if X
= Position
.Node
then
1852 if X
= X
.Next
then -- to prevent unnecessary looping
1868 (Stream
: not null access Root_Stream_Type
'Class;
1872 Write_Nodes
(Stream
, Container
.HT
);
1876 (Stream
: not null access Root_Stream_Type
'Class;
1880 raise Program_Error
with "attempt to stream set cursor";
1884 (Stream
: not null access Root_Stream_Type
'Class;
1885 Item
: Constant_Reference_Type
)
1888 raise Program_Error
with "attempt to stream reference";
1895 procedure Write_Node
1896 (Stream
: not null access Root_Stream_Type
'Class;
1900 Element_Type
'Write (Stream
, Node
.Element
);
1903 package body Generic_Keys
is
1905 -----------------------
1906 -- Local Subprograms --
1907 -----------------------
1909 function Equivalent_Key_Node
1911 Node
: Node_Access
) return Boolean;
1912 pragma Inline
(Equivalent_Key_Node
);
1914 --------------------------
1915 -- Local Instantiations --
1916 --------------------------
1919 new Hash_Tables
.Generic_Keys
1920 (HT_Types
=> HT_Types
,
1922 Set_Next
=> Set_Next
,
1923 Key_Type
=> Key_Type
,
1925 Equivalent_Keys
=> Equivalent_Key_Node
);
1927 ------------------------
1928 -- Constant_Reference --
1929 ------------------------
1931 function Constant_Reference
1932 (Container
: aliased Set
;
1933 Key
: Key_Type
) return Constant_Reference_Type
1935 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.HT
;
1936 Node
: constant Node_Access
:= Key_Keys
.Find
(HT
, Key
);
1940 raise Constraint_Error
with "Key not in set";
1944 B
: Natural renames HT
.Busy
;
1945 L
: Natural renames HT
.Lock
;
1947 return R
: constant Constant_Reference_Type
:=
1948 (Element
=> Node
.Element
'Access,
1949 Control
=> (Controlled
with Container
'Unrestricted_Access))
1955 end Constant_Reference
;
1963 Key
: Key_Type
) return Boolean
1966 return Find
(Container
, Key
) /= No_Element
;
1974 (Container
: in out Set
;
1980 Key_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Key
, X
);
1983 raise Constraint_Error
with "attempt to delete key not in set";
1995 Key
: Key_Type
) return Element_Type
1997 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.HT
;
1998 Node
: constant Node_Access
:= Key_Keys
.Find
(HT
, Key
);
2002 raise Constraint_Error
with "key not in set";
2005 return Node
.Element
;
2008 -------------------------
2009 -- Equivalent_Key_Node --
2010 -------------------------
2012 function Equivalent_Key_Node
2014 Node
: Node_Access
) return Boolean
2017 return Equivalent_Keys
(Key
, Generic_Keys
.Key
(Node
.Element
));
2018 end Equivalent_Key_Node
;
2025 (Container
: in out Set
;
2030 Key_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Key
, X
);
2040 Key
: Key_Type
) return Cursor
2042 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.HT
;
2043 Node
: constant Node_Access
:= Key_Keys
.Find
(HT
, Key
);
2050 return Cursor
'(Container'Unrestricted_Access, Node);
2057 function Key (Position : Cursor) return Key_Type is
2059 if Position.Node = null then
2060 raise Constraint_Error with
2061 "Position cursor equals No_Element";
2064 pragma Assert (Vet (Position), "bad cursor in function Key");
2066 return Key (Position.Node.Element);
2074 (Stream : not null access Root_Stream_Type'Class;
2075 Item : out Reference_Type)
2078 raise Program_Error with "attempt to stream reference";
2081 ------------------------------
2082 -- Reference_Preserving_Key --
2083 ------------------------------
2085 function Reference_Preserving_Key
2086 (Container : aliased in out Set;
2087 Position : Cursor) return Reference_Type
2090 if Position.Container = null then
2091 raise Constraint_Error with "Position cursor has no element";
2094 if Position.Container /= Container'Unrestricted_Access then
2095 raise Program_Error with
2096 "Position cursor designates wrong container";
2101 "bad cursor in function Reference_Preserving_Key");
2103 -- Some form of finalization will be required in order to actually
2104 -- check that the key-part of the element designated by Position has
2107 return (Element => Position.Node.Element'Access);
2108 end Reference_Preserving_Key;
2110 function Reference_Preserving_Key
2111 (Container : aliased in out Set;
2112 Key : Key_Type) return Reference_Type
2114 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2118 raise Constraint_Error with "Key not in set";
2121 -- Some form of finalization will be required in order to actually
2122 -- check that the key-part of the element designated by Key has not
2125 return (Element => Node.Element'Access);
2126 end Reference_Preserving_Key;
2133 (Container : in out Set;
2135 New_Item : Element_Type)
2137 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2141 raise Constraint_Error with
2142 "attempt to replace key not in set";
2145 Replace_Element (Container.HT, Node, New_Item);
2148 -----------------------------------
2149 -- Update_Element_Preserving_Key --
2150 -----------------------------------
2152 procedure Update_Element_Preserving_Key
2153 (Container : in out Set;
2155 Process : not null access
2156 procedure (Element : in out Element_Type))
2158 HT : Hash_Table_Type renames Container.HT;
2162 if Position.Node = null then
2163 raise Constraint_Error with
2164 "Position cursor equals No_Element";
2167 if Position.Container /= Container'Unrestricted_Access then
2168 raise Program_Error with
2169 "Position cursor designates wrong set";
2172 if HT.Buckets = null
2173 or else HT.Buckets'Length = 0
2174 or else HT.Length = 0
2175 or else Position.Node.Next = Position.Node
2177 raise Program_Error with "Position cursor is bad (set is empty)";
2182 "bad cursor in Update_Element_Preserving_Key");
2184 -- Per AI05-0022, the container implementation is required to detect
2185 -- element tampering by a generic actual subprogram.
2188 E : Element_Type renames Position.Node.Element;
2189 K : constant Key_Type := Key (E);
2191 B : Natural renames HT.Busy;
2192 L : Natural renames HT.Lock;
2201 Indx := HT_Ops.Index (HT, Position.Node);
2203 Eq := Equivalent_Keys (K, Key (E));
2219 if HT.Buckets (Indx) = Position.Node then
2220 HT.Buckets (Indx) := Position.Node.Next;
2224 Prev : Node_Access := HT.Buckets (Indx);
2227 while Prev.Next /= Position.Node loop
2231 raise Program_Error with
2232 "Position cursor is bad (node not found)";
2236 Prev.Next := Position.Node.Next;
2240 HT.Length := HT.Length - 1;
2243 X : Node_Access := Position.Node;
2249 raise Program_Error with "key was modified";
2250 end Update_Element_Preserving_Key;
2257 (Stream : not null access Root_Stream_Type'Class;
2258 Item : Reference_Type)
2261 raise Program_Error with "attempt to stream reference";
2266 end Ada.Containers.Hashed_Sets;