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-2017, 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
.Helpers
; use Ada
.Containers
.Helpers
;
40 with Ada
.Containers
.Prime_Numbers
;
42 with System
; use type System
.Address
;
44 package body Ada
.Containers
.Hashed_Sets
is
46 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
47 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
48 -- See comment in Ada.Containers.Helpers
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
54 procedure Assign
(Node
: Node_Access
; Item
: Element_Type
);
55 pragma Inline
(Assign
);
57 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
58 pragma Inline
(Copy_Node
);
60 function Equivalent_Keys
62 Node
: Node_Access
) return Boolean;
63 pragma Inline
(Equivalent_Keys
);
65 function Find_Equal_Key
66 (R_HT
: Hash_Table_Type
;
67 L_Node
: Node_Access
) return Boolean;
69 function Find_Equivalent_Key
70 (R_HT
: Hash_Table_Type
;
71 L_Node
: Node_Access
) return Boolean;
73 procedure Free
(X
: in out Node_Access
);
75 function Hash_Node
(Node
: Node_Access
) return Hash_Type
;
76 pragma Inline
(Hash_Node
);
79 (HT
: in out Hash_Table_Type
;
80 New_Item
: Element_Type
;
81 Node
: out Node_Access
;
82 Inserted
: out Boolean);
85 (HT
: aliased in out Hash_Table_Type
;
86 Key
: Node_Access
) return Boolean;
87 pragma Inline
(Is_In
);
89 function Next
(Node
: Node_Access
) return Node_Access
;
92 function Read_Node
(Stream
: not null access Root_Stream_Type
'Class)
94 pragma Inline
(Read_Node
);
96 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
);
97 pragma Inline
(Set_Next
);
99 function Vet
(Position
: Cursor
) return Boolean;
102 (Stream
: not null access Root_Stream_Type
'Class;
104 pragma Inline
(Write_Node
);
106 --------------------------
107 -- Local Instantiations --
108 --------------------------
110 package HT_Ops
is new Hash_Tables
.Generic_Operations
111 (HT_Types
=> HT_Types
,
112 Hash_Node
=> Hash_Node
,
114 Set_Next
=> Set_Next
,
115 Copy_Node
=> Copy_Node
,
118 package Element_Keys
is new Hash_Tables
.Generic_Keys
119 (HT_Types
=> HT_Types
,
121 Set_Next
=> Set_Next
,
122 Key_Type
=> Element_Type
,
124 Equivalent_Keys
=> Equivalent_Keys
);
127 new HT_Ops
.Generic_Equal
(Find_Equal_Key
);
129 function Is_Equivalent
is
130 new HT_Ops
.Generic_Equal
(Find_Equivalent_Key
);
132 procedure Read_Nodes
is
133 new HT_Ops
.Generic_Read
(Read_Node
);
135 procedure Replace_Element
is
136 new Element_Keys
.Generic_Replace_Element
(Hash_Node
, Assign
);
138 procedure Write_Nodes
is
139 new HT_Ops
.Generic_Write
(Write_Node
);
145 function "=" (Left
, Right
: Set
) return Boolean is
147 return Is_Equal
(Left
.HT
, Right
.HT
);
154 procedure Adjust
(Container
: in out Set
) is
156 HT_Ops
.Adjust
(Container
.HT
);
163 procedure Assign
(Node
: Node_Access
; Item
: Element_Type
) is
165 Node
.Element
:= Item
;
168 procedure Assign
(Target
: in out Set
; Source
: Set
) is
170 if Target
'Address = Source
'Address then
175 Target
.Union
(Source
);
182 function Capacity
(Container
: Set
) return Count_Type
is
184 return HT_Ops
.Capacity
(Container
.HT
);
191 procedure Clear
(Container
: in out Set
) is
193 HT_Ops
.Clear
(Container
.HT
);
196 ------------------------
197 -- Constant_Reference --
198 ------------------------
200 function Constant_Reference
201 (Container
: aliased Set
;
202 Position
: Cursor
) return Constant_Reference_Type
205 if Checks
and then Position
.Container
= null then
206 raise Constraint_Error
with "Position cursor has no element";
209 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
211 raise Program_Error
with
212 "Position cursor designates wrong container";
215 pragma Assert
(Vet
(Position
), "bad cursor in Constant_Reference");
218 HT
: Hash_Table_Type
renames Position
.Container
.all.HT
;
219 TC
: constant Tamper_Counts_Access
:=
220 HT
.TC
'Unrestricted_Access;
222 return R
: constant Constant_Reference_Type
:=
223 (Element
=> Position
.Node
.Element
'Access,
224 Control
=> (Controlled
with TC
))
229 end Constant_Reference
;
235 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean is
237 return Find
(Container
, Item
) /= No_Element
;
246 Capacity
: Count_Type
:= 0) return Set
251 if Capacity
< Source
.Length
then
252 if Checks
and then Capacity
/= 0 then
254 with "Requested capacity is less than Source length";
262 return Target
: Set
do
263 Target
.Reserve_Capacity
(C
);
264 Target
.Assign
(Source
);
272 function Copy_Node
(Source
: Node_Access
) return Node_Access
is
274 return new Node_Type
'(Element => Source.Element, Next => null);
282 (Container : in out Set;
288 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
290 if Checks and then X = null then
291 raise Constraint_Error with "attempt to delete element not in set";
298 (Container : in out Set;
299 Position : in out Cursor)
302 if Checks and then Position.Node = null then
303 raise Constraint_Error with "Position cursor equals No_Element";
306 if Checks and then Position.Container /= Container'Unrestricted_Access
308 raise Program_Error with "Position cursor designates wrong set";
311 TC_Check (Container.HT.TC);
313 pragma Assert (Vet (Position), "bad cursor in Delete");
315 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
317 Free (Position.Node);
318 Position.Container := null;
326 (Target : in out Set;
329 Tgt_Node : Node_Access;
330 Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT;
333 if Target'Address = Source'Address then
338 if Src_HT.Length = 0 then
342 TC_Check (Target.HT.TC);
344 if Src_HT.Length < Target.HT.Length then
346 Src_Node : Node_Access;
349 Src_Node := HT_Ops.First (Src_HT);
350 while Src_Node /= null loop
351 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element);
353 if Tgt_Node /= null then
354 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
358 Src_Node := HT_Ops.Next (Src_HT, Src_Node);
363 Tgt_Node := HT_Ops.First (Target.HT);
364 while Tgt_Node /= null loop
365 if Is_In (Src_HT, Tgt_Node) then
367 X : Node_Access := Tgt_Node;
369 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
370 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
375 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
381 function Difference (Left, Right : Set) return Set is
382 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
383 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
384 Buckets : HT_Types.Buckets_Access;
388 if Left'Address = Right'Address then
392 if Left_HT.Length = 0 then
396 if Right_HT.Length = 0 then
401 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
403 Buckets := HT_Ops.New_Buckets (Length => Size);
408 Iterate_Left : declare
409 procedure Process (L_Node : Node_Access);
412 new HT_Ops.Generic_Iteration (Process);
418 procedure Process (L_Node : Node_Access) is
420 if not Is_In (Right_HT, L_Node) then
422 -- Per AI05-0022, the container implementation is required
423 -- to detect element tampering by a generic actual
424 -- subprogram, hence the use of Checked_Index instead of a
425 -- simple invocation of generic formal Hash.
427 J : constant Hash_Type :=
428 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
430 Bucket : Node_Access renames Buckets (J);
433 Bucket := new Node_Type'(L_Node
.Element
, Bucket
);
436 Length
:= Length
+ 1;
440 -- Start of processing for Iterate_Left
446 HT_Ops
.Free_Hash_Table
(Buckets
);
450 return (Controlled
with HT
=> (Buckets
, Length
, (Busy
=> 0, Lock
=> 0)));
457 function Element
(Position
: Cursor
) return Element_Type
is
459 if Checks
and then Position
.Node
= null then
460 raise Constraint_Error
with "Position cursor equals No_Element";
463 pragma Assert
(Vet
(Position
), "bad cursor in function Element");
465 return Position
.Node
.Element
;
468 ---------------------
469 -- Equivalent_Sets --
470 ---------------------
472 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
474 return Is_Equivalent
(Left
.HT
, Right
.HT
);
477 -------------------------
478 -- Equivalent_Elements --
479 -------------------------
481 function Equivalent_Elements
(Left
, Right
: Cursor
)
484 if Checks
and then Left
.Node
= null then
485 raise Constraint_Error
with
486 "Left cursor of Equivalent_Elements equals No_Element";
489 if Checks
and then Right
.Node
= null then
490 raise Constraint_Error
with
491 "Right cursor of Equivalent_Elements equals No_Element";
494 pragma Assert
(Vet
(Left
), "bad Left cursor in Equivalent_Elements");
495 pragma Assert
(Vet
(Right
), "bad Right cursor in Equivalent_Elements");
497 -- AI05-0022 requires that a container implementation detect element
498 -- tampering by a generic actual subprogram. However, the following case
499 -- falls outside the scope of that AI. Randy Brukardt explained on the
500 -- ARG list on 2013/02/07 that:
503 -- But for an operation like "<" [the ordered set analog of
504 -- Equivalent_Elements], there is no need to "dereference" a cursor
505 -- after the call to the generic formal parameter function, so nothing
506 -- bad could happen if tampering is undetected. And the operation can
507 -- safely return a result without a problem even if an element is
508 -- deleted from the container.
511 return Equivalent_Elements
(Left
.Node
.Element
, Right
.Node
.Element
);
512 end Equivalent_Elements
;
514 function Equivalent_Elements
(Left
: Cursor
; Right
: Element_Type
)
517 if Checks
and then Left
.Node
= null then
518 raise Constraint_Error
with
519 "Left cursor of Equivalent_Elements equals No_Element";
522 pragma Assert
(Vet
(Left
), "Left cursor in Equivalent_Elements is bad");
524 return Equivalent_Elements
(Left
.Node
.Element
, Right
);
525 end Equivalent_Elements
;
527 function Equivalent_Elements
(Left
: Element_Type
; Right
: Cursor
)
530 if Checks
and then Right
.Node
= null then
531 raise Constraint_Error
with
532 "Right cursor of Equivalent_Elements equals No_Element";
537 "Right cursor of Equivalent_Elements is bad");
539 return Equivalent_Elements
(Left
, Right
.Node
.Element
);
540 end Equivalent_Elements
;
542 ---------------------
543 -- Equivalent_Keys --
544 ---------------------
546 function Equivalent_Keys
(Key
: Element_Type
; Node
: Node_Access
)
549 return Equivalent_Elements
(Key
, Node
.Element
);
557 (Container
: in out Set
;
562 Element_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Item
, X
);
570 procedure Finalize
(Container
: in out Set
) is
572 HT_Ops
.Finalize
(Container
.HT
);
575 procedure Finalize
(Object
: in out Iterator
) is
577 if Object
.Container
/= null then
578 Unbusy
(Object
.Container
.HT
.TC
);
588 Item
: Element_Type
) return Cursor
590 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.HT
;
591 Node
: constant Node_Access
:= Element_Keys
.Find
(HT
, Item
);
598 return Cursor
'(Container'Unrestricted_Access, Node, Hash_Type'Last);
605 function Find_Equal_Key
606 (R_HT : Hash_Table_Type;
607 L_Node : Node_Access) return Boolean
609 R_Index : constant Hash_Type :=
610 Element_Keys.Index (R_HT, L_Node.Element);
612 R_Node : Node_Access := R_HT.Buckets (R_Index);
616 if R_Node = null then
620 if L_Node.Element = R_Node.Element then
624 R_Node := Next (R_Node);
628 -------------------------
629 -- Find_Equivalent_Key --
630 -------------------------
632 function Find_Equivalent_Key
633 (R_HT : Hash_Table_Type;
634 L_Node : Node_Access) return Boolean
636 R_Index : constant Hash_Type :=
637 Element_Keys.Index (R_HT, L_Node.Element);
639 R_Node : Node_Access := R_HT.Buckets (R_Index);
643 if R_Node = null then
647 if Equivalent_Elements (L_Node.Element, R_Node.Element) then
651 R_Node := Next (R_Node);
653 end Find_Equivalent_Key;
659 function First (Container : Set) return Cursor is
661 Node : constant Node_Access := HT_Ops.First (Container.HT, Pos);
667 return Cursor'(Container
'Unrestricted_Access, Node
, Pos
);
670 function First
(Object
: Iterator
) return Cursor
is
672 return Object
.Container
.First
;
679 procedure Free
(X
: in out Node_Access
) is
680 procedure Deallocate
is
681 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
685 X
.Next
:= X
; -- detect mischief (in Vet)
690 ------------------------
691 -- Get_Element_Access --
692 ------------------------
694 function Get_Element_Access
695 (Position
: Cursor
) return not null Element_Access
is
697 return Position
.Node
.Element
'Access;
698 end Get_Element_Access
;
704 function Has_Element
(Position
: Cursor
) return Boolean is
706 pragma Assert
(Vet
(Position
), "bad cursor in Has_Element");
707 return Position
.Node
/= null;
714 function Hash_Node
(Node
: Node_Access
) return Hash_Type
is
716 return Hash
(Node
.Element
);
724 (Container
: in out Set
;
725 New_Item
: Element_Type
)
731 Insert
(Container
, New_Item
, Position
, Inserted
);
734 TE_Check
(Container
.HT
.TC
);
736 Position
.Node
.Element
:= New_Item
;
745 (Container
: in out Set
;
746 New_Item
: Element_Type
;
747 Position
: out Cursor
;
748 Inserted
: out Boolean)
751 Insert
(Container
.HT
, New_Item
, Position
.Node
, Inserted
);
752 Position
.Container
:= Container
'Unchecked_Access;
756 (Container
: in out Set
;
757 New_Item
: Element_Type
)
760 pragma Unreferenced
(Position
);
765 Insert
(Container
, New_Item
, Position
, Inserted
);
767 if Checks
and then not Inserted
then
768 raise Constraint_Error
with
769 "attempt to insert element already in set";
774 (HT
: in out Hash_Table_Type
;
775 New_Item
: Element_Type
;
776 Node
: out Node_Access
;
777 Inserted
: out Boolean)
779 function New_Node
(Next
: Node_Access
) return Node_Access
;
780 pragma Inline
(New_Node
);
782 procedure Local_Insert
is
783 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
789 function New_Node
(Next
: Node_Access
) return Node_Access
is
791 return new Node_Type
'(New_Item, Next);
794 -- Start of processing for Insert
797 if HT_Ops.Capacity (HT) = 0 then
798 HT_Ops.Reserve_Capacity (HT, 1);
803 Local_Insert (HT, New_Item, Node, Inserted);
806 and then HT.Length > HT_Ops.Capacity (HT)
808 HT_Ops.Reserve_Capacity (HT, HT.Length);
816 procedure Intersection
817 (Target : in out Set;
820 Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT;
821 Tgt_Node : Node_Access;
824 if Target'Address = Source'Address then
828 if Source.HT.Length = 0 then
833 TC_Check (Target.HT.TC);
835 Tgt_Node := HT_Ops.First (Target.HT);
836 while Tgt_Node /= null loop
837 if Is_In (Src_HT, Tgt_Node) then
838 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
842 X : Node_Access := Tgt_Node;
844 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
845 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
852 function Intersection (Left, Right : Set) return Set is
853 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
854 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
855 Buckets : HT_Types.Buckets_Access;
859 if Left'Address = Right'Address then
863 Length := Count_Type'Min (Left.Length, Right.Length);
870 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
872 Buckets := HT_Ops.New_Buckets (Length => Size);
877 Iterate_Left : declare
878 procedure Process (L_Node : Node_Access);
881 new HT_Ops.Generic_Iteration (Process);
887 procedure Process (L_Node : Node_Access) is
889 if Is_In (Right_HT, L_Node) then
891 -- Per AI05-0022, the container implementation is required
892 -- to detect element tampering by a generic actual
893 -- subprogram, hence the use of Checked_Index instead of a
894 -- simple invocation of generic formal Hash.
896 J : constant Hash_Type :=
897 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
899 Bucket : Node_Access renames Buckets (J);
902 Bucket := new Node_Type'(L_Node
.Element
, Bucket
);
905 Length
:= Length
+ 1;
909 -- Start of processing for Iterate_Left
915 HT_Ops
.Free_Hash_Table
(Buckets
);
919 return (Controlled
with HT
=> (Buckets
, Length
, (Busy
=> 0, Lock
=> 0)));
926 function Is_Empty
(Container
: Set
) return Boolean is
928 return Container
.HT
.Length
= 0;
936 (HT
: aliased in out Hash_Table_Type
;
937 Key
: Node_Access
) return Boolean
940 return Element_Keys
.Find
(HT
, Key
.Element
) /= null;
947 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
948 Subset_HT
: Hash_Table_Type
renames Subset
'Unrestricted_Access.HT
;
949 Of_Set_HT
: Hash_Table_Type
renames Of_Set
'Unrestricted_Access.HT
;
950 Subset_Node
: Node_Access
;
953 if Subset
'Address = Of_Set
'Address then
957 if Subset
.Length
> Of_Set
.Length
then
961 Subset_Node
:= HT_Ops
.First
(Subset_HT
);
962 while Subset_Node
/= null loop
963 if not Is_In
(Of_Set_HT
, Subset_Node
) then
966 Subset_Node
:= HT_Ops
.Next
(Subset_HT
, Subset_Node
);
978 Process
: not null access procedure (Position
: Cursor
))
980 procedure Process_Node
(Node
: Node_Access
; Position
: Hash_Type
);
981 pragma Inline
(Process_Node
);
984 new HT_Ops
.Generic_Iteration_With_Position
(Process_Node
);
990 procedure Process_Node
(Node
: Node_Access
; Position
: Hash_Type
) is
992 Process
(Cursor
'(Container'Unrestricted_Access, Node, Position));
995 Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
997 -- Start of processing for Iterate
1000 Iterate (Container.HT);
1004 (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class
1007 Busy (Container.HT.TC'Unrestricted_Access.all);
1008 return It : constant Iterator :=
1009 Iterator'(Limited_Controlled
with
1010 Container
=> Container
'Unrestricted_Access);
1017 function Length
(Container
: Set
) return Count_Type
is
1019 return Container
.HT
.Length
;
1026 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1028 HT_Ops
.Move
(Target
=> Target
.HT
, Source
=> Source
.HT
);
1035 function Next
(Node
: Node_Access
) return Node_Access
is
1040 function Next
(Position
: Cursor
) return Cursor
is
1044 if Position
.Node
= null then
1048 pragma Assert
(Vet
(Position
), "bad cursor in Next");
1050 Pos
:= Position
.Position
;
1051 Node
:= HT_Ops
.Next
(Position
.Container
.HT
, Position
.Node
, Pos
);
1057 return Cursor
'(Position.Container, Node, Pos);
1060 procedure Next (Position : in out Cursor) is
1062 Position := Next (Position);
1067 Position : Cursor) return Cursor
1070 if Position.Container = null then
1074 if Checks and then Position.Container /= Object.Container then
1075 raise Program_Error with
1076 "Position cursor of Next designates wrong set";
1079 return Next (Position);
1086 function Overlap (Left, Right : Set) return Boolean is
1087 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
1088 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
1089 Left_Node : Node_Access;
1092 if Right.Length = 0 then
1096 if Left'Address = Right'Address then
1100 Left_Node := HT_Ops.First (Left_HT);
1101 while Left_Node /= null loop
1102 if Is_In (Right_HT, Left_Node) then
1105 Left_Node := HT_Ops.Next (Left_HT, Left_Node);
1111 ----------------------
1112 -- Pseudo_Reference --
1113 ----------------------
1115 function Pseudo_Reference
1116 (Container : aliased Set'Class) return Reference_Control_Type
1118 TC : constant Tamper_Counts_Access :=
1119 Container.HT.TC'Unrestricted_Access;
1121 return R : constant Reference_Control_Type := (Controlled with TC) do
1124 end Pseudo_Reference;
1130 procedure Query_Element
1132 Process : not null access procedure (Element : Element_Type))
1135 if Checks and then Position.Node = null then
1136 raise Constraint_Error with
1137 "Position cursor of Query_Element equals No_Element";
1140 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1143 HT : Hash_Table_Type renames Position.Container.HT;
1144 Lock : With_Lock (HT.TC'Unrestricted_Access);
1146 Process (Position.Node.Element);
1155 (Stream : not null access Root_Stream_Type'Class;
1156 Container : out Set)
1159 Read_Nodes (Stream, Container.HT);
1163 (Stream : not null access Root_Stream_Type'Class;
1167 raise Program_Error with "attempt to stream set cursor";
1171 (Stream : not null access Root_Stream_Type'Class;
1172 Item : out Constant_Reference_Type)
1175 raise Program_Error with "attempt to stream reference";
1182 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1185 Node : Node_Access := new Node_Type;
1187 Element_Type'Read (Stream, Node.Element);
1200 (Container : in out Set;
1201 New_Item : Element_Type)
1203 Node : constant Node_Access :=
1204 Element_Keys.Find (Container.HT, New_Item);
1207 if Checks and then Node = null then
1208 raise Constraint_Error with
1209 "attempt to replace element not in set";
1212 TE_Check (Container.HT.TC);
1214 Node.Element := New_Item;
1217 procedure Replace_Element
1218 (Container : in out Set;
1220 New_Item : Element_Type)
1223 if Checks and then Position.Node = null then
1224 raise Constraint_Error with
1225 "Position cursor equals No_Element";
1228 if Checks and then Position.Container /= Container'Unrestricted_Access
1230 raise Program_Error with
1231 "Position cursor designates wrong set";
1234 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1236 Replace_Element (Container.HT, Position.Node, New_Item);
1237 end Replace_Element;
1239 ----------------------
1240 -- Reserve_Capacity --
1241 ----------------------
1243 procedure Reserve_Capacity
1244 (Container : in out Set;
1245 Capacity : Count_Type)
1248 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1249 end Reserve_Capacity;
1255 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1260 --------------------------
1261 -- Symmetric_Difference --
1262 --------------------------
1264 procedure Symmetric_Difference
1265 (Target : in out Set;
1268 Tgt_HT : Hash_Table_Type renames Target.HT;
1269 Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all;
1271 if Target'Address = Source'Address then
1276 TC_Check (Tgt_HT.TC);
1279 N : constant Count_Type := Target.Length + Source.Length;
1281 if N > HT_Ops.Capacity (Tgt_HT) then
1282 HT_Ops.Reserve_Capacity (Tgt_HT, N);
1286 if Target.Length = 0 then
1287 Iterate_Source_When_Empty_Target : declare
1288 procedure Process (Src_Node : Node_Access);
1290 procedure Iterate is new HT_Ops.Generic_Iteration (Process);
1296 procedure Process (Src_Node : Node_Access) is
1297 E : Element_Type renames Src_Node.Element;
1298 B : Buckets_Type renames Tgt_HT.Buckets.all;
1299 J : constant Hash_Type := Hash (E) mod B'Length;
1300 N : Count_Type renames Tgt_HT.Length;
1303 B (J) := new Node_Type'(E
, B
(J
));
1307 -- Per AI05-0022, the container implementation is required to
1308 -- detect element tampering by a generic actual subprogram.
1310 Lock_Tgt
: With_Lock
(Tgt_HT
.TC
'Unrestricted_Access);
1311 Lock_Src
: With_Lock
(Src_HT
.TC
'Unrestricted_Access);
1313 -- Start of processing for Iterate_Source_When_Empty_Target
1317 end Iterate_Source_When_Empty_Target
;
1320 Iterate_Source
: declare
1321 procedure Process
(Src_Node
: Node_Access
);
1323 procedure Iterate
is
1324 new HT_Ops
.Generic_Iteration
(Process
);
1330 procedure Process
(Src_Node
: Node_Access
) is
1331 E
: Element_Type
renames Src_Node
.Element
;
1332 B
: Buckets_Type
renames Tgt_HT
.Buckets
.all;
1333 J
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
1334 N
: Count_Type
renames Tgt_HT
.Length
;
1337 if B
(J
) = null then
1338 B
(J
) := new Node_Type
'(E, null);
1341 elsif Equivalent_Elements (E, B (J).Element) then
1343 X : Node_Access := B (J);
1345 B (J) := B (J).Next;
1352 Prev : Node_Access := B (J);
1353 Curr : Node_Access := Prev.Next;
1356 while Curr /= null loop
1357 if Equivalent_Elements (E, Curr.Element) then
1358 Prev.Next := Curr.Next;
1368 B (J) := new Node_Type'(E
, B
(J
));
1374 -- Per AI05-0022, the container implementation is required to
1375 -- detect element tampering by a generic actual subprogram.
1377 Lock_Tgt
: With_Lock
(Tgt_HT
.TC
'Unrestricted_Access);
1378 Lock_Src
: With_Lock
(Src_HT
.TC
'Unrestricted_Access);
1380 -- Start of processing for Iterate_Source
1386 end Symmetric_Difference
;
1388 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
1389 Left_HT
: Hash_Table_Type
renames Left
'Unrestricted_Access.HT
;
1390 Right_HT
: Hash_Table_Type
renames Right
'Unrestricted_Access.HT
;
1391 Buckets
: HT_Types
.Buckets_Access
;
1392 Length
: Count_Type
;
1395 if Left
'Address = Right
'Address then
1399 if Right
.Length
= 0 then
1403 if Left
.Length
= 0 then
1408 Size
: constant Hash_Type
:=
1409 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1411 Buckets
:= HT_Ops
.New_Buckets
(Length
=> Size
);
1416 Iterate_Left
: declare
1417 procedure Process
(L_Node
: Node_Access
);
1419 procedure Iterate
is
1420 new HT_Ops
.Generic_Iteration
(Process
);
1426 procedure Process
(L_Node
: Node_Access
) is
1428 if not Is_In
(Right_HT
, L_Node
) then
1430 E
: Element_Type
renames L_Node
.Element
;
1432 -- Per AI05-0022, the container implementation is required
1433 -- to detect element tampering by a generic actual
1434 -- subprogram, hence the use of Checked_Index instead of a
1435 -- simple invocation of generic formal Hash.
1437 J
: constant Hash_Type
:=
1438 HT_Ops
.Checked_Index
(Left_HT
, Buckets
.all, L_Node
);
1441 Buckets
(J
) := new Node_Type
'(E, Buckets (J));
1442 Length := Length + 1;
1447 -- Start of processing for Iterate_Left
1454 HT_Ops.Free_Hash_Table (Buckets);
1458 Iterate_Right : declare
1459 procedure Process (R_Node : Node_Access);
1461 procedure Iterate is
1462 new HT_Ops.Generic_Iteration (Process);
1468 procedure Process (R_Node : Node_Access) is
1470 if not Is_In (Left_HT, R_Node) then
1472 E : Element_Type renames R_Node.Element;
1474 -- Per AI05-0022, the container implementation is required
1475 -- to detect element tampering by a generic actual
1476 -- subprogram, hence the use of Checked_Index instead of a
1477 -- simple invocation of generic formal Hash.
1479 J : constant Hash_Type :=
1480 HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node);
1483 Buckets (J) := new Node_Type'(E
, Buckets
(J
));
1484 Length
:= Length
+ 1;
1489 -- Start of processing for Iterate_Right
1496 HT_Ops
.Free_Hash_Table
(Buckets
);
1500 return (Controlled
with HT
=> (Buckets
, Length
, (Busy
=> 0, Lock
=> 0)));
1501 end Symmetric_Difference
;
1507 function To_Set
(New_Item
: Element_Type
) return Set
is
1508 HT
: Hash_Table_Type
;
1512 pragma Unreferenced
(Node
, Inserted
);
1515 Insert
(HT
, New_Item
, Node
, Inserted
);
1516 return Set
'(Controlled with HT);
1524 (Target : in out Set;
1527 procedure Process (Src_Node : Node_Access);
1529 procedure Iterate is
1530 new HT_Ops.Generic_Iteration (Process);
1536 procedure Process (Src_Node : Node_Access) is
1537 function New_Node (Next : Node_Access) return Node_Access;
1538 pragma Inline (New_Node);
1541 new Element_Keys.Generic_Conditional_Insert (New_Node);
1547 function New_Node (Next : Node_Access) return Node_Access is
1548 Node : constant Node_Access :=
1549 new Node_Type'(Src_Node
.Element
, Next
);
1554 Tgt_Node
: Node_Access
;
1556 pragma Unreferenced
(Tgt_Node
, Success
);
1558 -- Start of processing for Process
1561 Insert
(Target
.HT
, Src_Node
.Element
, Tgt_Node
, Success
);
1564 -- Start of processing for Union
1567 if Target
'Address = Source
'Address then
1571 TC_Check
(Target
.HT
.TC
);
1574 N
: constant Count_Type
:= Target
.Length
+ Source
.Length
;
1576 if N
> HT_Ops
.Capacity
(Target
.HT
) then
1577 HT_Ops
.Reserve_Capacity
(Target
.HT
, N
);
1581 Iterate
(Source
.HT
);
1584 function Union
(Left
, Right
: Set
) return Set
is
1585 Left_HT
: Hash_Table_Type
renames Left
.HT
'Unrestricted_Access.all;
1586 Right_HT
: Hash_Table_Type
renames Right
.HT
'Unrestricted_Access.all;
1587 Buckets
: HT_Types
.Buckets_Access
;
1588 Length
: Count_Type
;
1591 if Left
'Address = Right
'Address then
1595 if Right
.Length
= 0 then
1599 if Left
.Length
= 0 then
1604 Size
: constant Hash_Type
:=
1605 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1607 Buckets
:= HT_Ops
.New_Buckets
(Length
=> Size
);
1610 Iterate_Left
: declare
1611 procedure Process
(L_Node
: Node_Access
);
1613 procedure Iterate
is
1614 new HT_Ops
.Generic_Iteration
(Process
);
1620 procedure Process
(L_Node
: Node_Access
) is
1621 J
: constant Hash_Type
:=
1622 Hash
(L_Node
.Element
) mod Buckets
'Length;
1625 Buckets
(J
) := new Node_Type
'(L_Node.Element, Buckets (J));
1628 -- Per AI05-0022, the container implementation is required to detect
1629 -- element tampering by a generic actual subprogram, hence the use of
1630 -- Checked_Index instead of a simple invocation of generic formal
1633 Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access);
1635 -- Start of processing for Iterate_Left
1641 HT_Ops.Free_Hash_Table (Buckets);
1645 Length := Left.Length;
1647 Iterate_Right : declare
1648 procedure Process (Src_Node : Node_Access);
1650 procedure Iterate is
1651 new HT_Ops.Generic_Iteration (Process);
1657 procedure Process (Src_Node : Node_Access) is
1658 J : constant Hash_Type :=
1659 Hash (Src_Node.Element) mod Buckets'Length;
1661 Tgt_Node : Node_Access := Buckets (J);
1664 while Tgt_Node /= null loop
1665 if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1669 Tgt_Node := Next (Tgt_Node);
1672 Buckets (J) := new Node_Type'(Src_Node
.Element
, Buckets
(J
));
1673 Length
:= Length
+ 1;
1676 -- Per AI05-0022, the container implementation is required to detect
1677 -- element tampering by a generic actual subprogram, hence the use of
1678 -- Checked_Index instead of a simple invocation of generic formal
1681 Lock_Left
: With_Lock
(Left_HT
.TC
'Unrestricted_Access);
1682 Lock_Right
: With_Lock
(Right_HT
.TC
'Unrestricted_Access);
1684 -- Start of processing for Iterate_Right
1690 HT_Ops
.Free_Hash_Table
(Buckets
);
1694 return (Controlled
with HT
=> (Buckets
, Length
, (Busy
=> 0, Lock
=> 0)));
1701 function Vet
(Position
: Cursor
) return Boolean is
1703 if Position
.Node
= null then
1704 return Position
.Container
= null;
1707 if Position
.Container
= null then
1711 if Position
.Node
.Next
= Position
.Node
then
1716 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
1720 if HT
.Length
= 0 then
1724 if HT
.Buckets
= null
1725 or else HT
.Buckets
'Length = 0
1730 X
:= HT
.Buckets
(Element_Keys
.Checked_Index
1732 Position
.Node
.Element
));
1734 for J
in 1 .. HT
.Length
loop
1735 if X
= Position
.Node
then
1743 if X
= X
.Next
then -- to prevent unnecessary looping
1759 (Stream
: not null access Root_Stream_Type
'Class;
1763 Write_Nodes
(Stream
, Container
.HT
);
1767 (Stream
: not null access Root_Stream_Type
'Class;
1771 raise Program_Error
with "attempt to stream set cursor";
1775 (Stream
: not null access Root_Stream_Type
'Class;
1776 Item
: Constant_Reference_Type
)
1779 raise Program_Error
with "attempt to stream reference";
1786 procedure Write_Node
1787 (Stream
: not null access Root_Stream_Type
'Class;
1791 Element_Type
'Write (Stream
, Node
.Element
);
1794 package body Generic_Keys
is
1796 -----------------------
1797 -- Local Subprograms --
1798 -----------------------
1800 function Equivalent_Key_Node
1802 Node
: Node_Access
) return Boolean;
1803 pragma Inline
(Equivalent_Key_Node
);
1805 --------------------------
1806 -- Local Instantiations --
1807 --------------------------
1810 new Hash_Tables
.Generic_Keys
1811 (HT_Types
=> HT_Types
,
1813 Set_Next
=> Set_Next
,
1814 Key_Type
=> Key_Type
,
1816 Equivalent_Keys
=> Equivalent_Key_Node
);
1818 ------------------------
1819 -- Constant_Reference --
1820 ------------------------
1822 function Constant_Reference
1823 (Container
: aliased Set
;
1824 Key
: Key_Type
) return Constant_Reference_Type
1826 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.HT
;
1827 Node
: constant Node_Access
:= Key_Keys
.Find
(HT
, Key
);
1830 if Checks
and then Node
= null then
1831 raise Constraint_Error
with "Key not in set";
1835 TC
: constant Tamper_Counts_Access
:=
1836 HT
.TC
'Unrestricted_Access;
1838 return R
: constant Constant_Reference_Type
:=
1839 (Element
=> Node
.Element
'Access,
1840 Control
=> (Controlled
with TC
))
1845 end Constant_Reference
;
1853 Key
: Key_Type
) return Boolean
1856 return Find
(Container
, Key
) /= No_Element
;
1864 (Container
: in out Set
;
1870 Key_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Key
, X
);
1872 if Checks
and then X
= null then
1873 raise Constraint_Error
with "attempt to delete key not in set";
1885 Key
: Key_Type
) return Element_Type
1887 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.HT
;
1888 Node
: constant Node_Access
:= Key_Keys
.Find
(HT
, Key
);
1891 if Checks
and then Node
= null then
1892 raise Constraint_Error
with "key not in set";
1895 return Node
.Element
;
1898 -------------------------
1899 -- Equivalent_Key_Node --
1900 -------------------------
1902 function Equivalent_Key_Node
1904 Node
: Node_Access
) return Boolean
1907 return Equivalent_Keys
(Key
, Generic_Keys
.Key
(Node
.Element
));
1908 end Equivalent_Key_Node
;
1915 (Container
: in out Set
;
1920 Key_Keys
.Delete_Key_Sans_Free
(Container
.HT
, Key
, X
);
1928 procedure Finalize
(Control
: in out Reference_Control_Type
) is
1930 if Control
.Container
/= null then
1931 Impl
.Reference_Control_Type
(Control
).Finalize
;
1934 Hash
(Key
(Element
(Control
.Old_Pos
))) /= Control
.Old_Hash
1936 HT_Ops
.Delete_Node_At_Index
1937 (Control
.Container
.HT
, Control
.Index
, Control
.Old_Pos
.Node
);
1938 raise Program_Error
with "key not preserved in reference";
1941 Control
.Container
:= null;
1951 Key
: Key_Type
) return Cursor
1953 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.HT
;
1954 Node
: constant Node_Access
:= Key_Keys
.Find
(HT
, Key
);
1960 (Container'Unrestricted_Access, Node, Hash_Type'Last);
1968 function Key (Position : Cursor) return Key_Type is
1970 if Checks and then Position.Node = null then
1971 raise Constraint_Error with
1972 "Position cursor equals No_Element";
1975 pragma Assert (Vet (Position), "bad cursor in function Key");
1977 return Key (Position.Node.Element);
1985 (Stream : not null access Root_Stream_Type'Class;
1986 Item : out Reference_Type)
1989 raise Program_Error with "attempt to stream reference";
1992 ------------------------------
1993 -- Reference_Preserving_Key --
1994 ------------------------------
1996 function Reference_Preserving_Key
1997 (Container : aliased in out Set;
1998 Position : Cursor) return Reference_Type
2001 if Checks and then Position.Container = null then
2002 raise Constraint_Error with "Position cursor has no element";
2005 if Checks and then Position.Container /= Container'Unrestricted_Access
2007 raise Program_Error with
2008 "Position cursor designates wrong container";
2013 "bad cursor in function Reference_Preserving_Key");
2016 HT : Hash_Table_Type renames Position.Container.all.HT;
2018 return R : constant Reference_Type :=
2019 (Element => Position.Node.Element'Access,
2022 HT.TC'Unrestricted_Access,
2023 Container'Unrestricted_Access,
2024 Index => HT_Ops.Index (HT, Position.Node),
2025 Old_Pos => Position,
2026 Old_Hash => Hash (Key (Position))))
2031 end Reference_Preserving_Key;
2033 function Reference_Preserving_Key
2034 (Container : aliased in out Set;
2035 Key : Key_Type) return Reference_Type
2037 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2040 if Checks and then Node = null then
2041 raise Constraint_Error with "key not in set";
2045 HT : Hash_Table_Type renames Container.HT;
2046 P : constant Cursor := Find (Container, Key);
2048 return R : constant Reference_Type :=
2049 (Element => Node.Element'Access,
2052 HT.TC'Unrestricted_Access,
2053 Container'Unrestricted_Access,
2054 Index => HT_Ops.Index (HT, P.Node),
2056 Old_Hash => Hash (Key)))
2061 end Reference_Preserving_Key;
2068 (Container : in out Set;
2070 New_Item : Element_Type)
2072 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2075 if Checks and then Node = null then
2076 raise Constraint_Error with
2077 "attempt to replace key not in set";
2080 Replace_Element (Container.HT, Node, New_Item);
2083 -----------------------------------
2084 -- Update_Element_Preserving_Key --
2085 -----------------------------------
2087 procedure Update_Element_Preserving_Key
2088 (Container : in out Set;
2090 Process : not null access
2091 procedure (Element : in out Element_Type))
2093 HT : Hash_Table_Type renames Container.HT;
2097 if Checks and then Position.Node = null then
2098 raise Constraint_Error with
2099 "Position cursor equals No_Element";
2102 if Checks and then Position.Container /= Container'Unrestricted_Access
2104 raise Program_Error with
2105 "Position cursor designates wrong set";
2110 or else HT.Buckets'Length = 0
2111 or else HT.Length = 0
2112 or else Position.Node.Next = Position.Node)
2114 raise Program_Error with "Position cursor is bad (set is empty)";
2119 "bad cursor in Update_Element_Preserving_Key");
2121 -- Per AI05-0022, the container implementation is required to detect
2122 -- element tampering by a generic actual subprogram.
2125 E : Element_Type renames Position.Node.Element;
2126 K : constant Key_Type := Key (E);
2127 Lock : With_Lock (HT.TC'Unrestricted_Access);
2129 Indx := HT_Ops.Index (HT, Position.Node);
2132 if Equivalent_Keys (K, Key (E)) then
2137 if HT.Buckets (Indx) = Position.Node then
2138 HT.Buckets (Indx) := Position.Node.Next;
2142 Prev : Node_Access := HT.Buckets (Indx);
2145 while Prev.Next /= Position.Node loop
2148 if Checks and then Prev = null then
2149 raise Program_Error with
2150 "Position cursor is bad (node not found)";
2154 Prev.Next := Position.Node.Next;
2158 HT.Length := HT.Length - 1;
2161 X : Node_Access := Position.Node;
2167 raise Program_Error with "key was modified";
2168 end Update_Element_Preserving_Key;
2175 (Stream : not null access Root_Stream_Type'Class;
2176 Item : Reference_Type)
2179 raise Program_Error with "attempt to stream reference";
2184 end Ada.Containers.Hashed_Sets;