1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_HASHED_SETS --
9 -- Copyright (C) 2004-2012, 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
.Indefinite_Hashed_Sets
is
44 type Iterator
is new Limited_Controlled
and
45 Set_Iterator_Interfaces
.Forward_Iterator
with
47 Container
: Set_Access
;
50 overriding
procedure Finalize
(Object
: in out Iterator
);
52 overriding
function First
(Object
: Iterator
) return Cursor
;
54 overriding
function Next
56 Position
: Cursor
) return Cursor
;
58 -----------------------
59 -- Local Subprograms --
60 -----------------------
62 procedure Assign
(Node
: Node_Access
; Item
: Element_Type
);
63 pragma Inline
(Assign
);
65 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
66 pragma Inline
(Copy_Node
);
68 function Equivalent_Keys
70 Node
: Node_Access
) return Boolean;
71 pragma Inline
(Equivalent_Keys
);
73 function Find_Equal_Key
74 (R_HT
: Hash_Table_Type
;
75 L_Node
: Node_Access
) return Boolean;
77 function Find_Equivalent_Key
78 (R_HT
: Hash_Table_Type
;
79 L_Node
: Node_Access
) return Boolean;
81 procedure Free
(X
: in out Node_Access
);
83 function Hash_Node
(Node
: Node_Access
) return Hash_Type
;
84 pragma Inline
(Hash_Node
);
87 (HT
: in out Hash_Table_Type
;
88 New_Item
: Element_Type
;
89 Node
: out Node_Access
;
90 Inserted
: out Boolean);
92 function Is_In
(HT
: Hash_Table_Type
; Key
: Node_Access
) return Boolean;
93 pragma Inline
(Is_In
);
95 function Next
(Node
: Node_Access
) return Node_Access
;
98 function Read_Node
(Stream
: not null access Root_Stream_Type
'Class)
100 pragma Inline
(Read_Node
);
102 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
);
103 pragma Inline
(Set_Next
);
105 function Vet
(Position
: Cursor
) return Boolean;
108 (Stream
: not null access Root_Stream_Type
'Class;
110 pragma Inline
(Write_Node
);
112 --------------------------
113 -- Local Instantiations --
114 --------------------------
116 procedure Free_Element
is
117 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
119 package HT_Ops
is new Hash_Tables
.Generic_Operations
120 (HT_Types
=> HT_Types
,
121 Hash_Node
=> Hash_Node
,
123 Set_Next
=> Set_Next
,
124 Copy_Node
=> Copy_Node
,
127 package Element_Keys
is new Hash_Tables
.Generic_Keys
128 (HT_Types
=> HT_Types
,
130 Set_Next
=> Set_Next
,
131 Key_Type
=> Element_Type
,
133 Equivalent_Keys
=> Equivalent_Keys
);
136 new HT_Ops
.Generic_Equal
(Find_Equal_Key
);
138 function Is_Equivalent
is
139 new HT_Ops
.Generic_Equal
(Find_Equivalent_Key
);
141 procedure Read_Nodes
is
142 new HT_Ops
.Generic_Read
(Read_Node
);
144 procedure Replace_Element
is
145 new Element_Keys
.Generic_Replace_Element
(Hash_Node
, Assign
);
147 procedure Write_Nodes
is
148 new HT_Ops
.Generic_Write
(Write_Node
);
154 function "=" (Left
, Right
: Set
) return Boolean is
156 return Is_Equal
(Left
.HT
, Right
.HT
);
163 procedure Adjust
(Container
: in out Set
) is
165 HT_Ops
.Adjust
(Container
.HT
);
168 procedure Adjust
(Control
: in out Reference_Control_Type
) is
170 if Control
.Container
/= null then
172 HT
: Hash_Table_Type
renames Control
.Container
.all.HT
;
173 B
: Natural renames HT
.Busy
;
174 L
: Natural renames HT
.Lock
;
186 procedure Assign
(Node
: Node_Access
; Item
: Element_Type
) is
187 X
: Element_Access
:= Node
.Element
;
189 -- The element allocator may need an accessibility check in the case the
190 -- actual type is class-wide or has access discriminants (RM 4.8(10.1)
193 pragma Unsuppress
(Accessibility_Check
);
196 Node
.Element
:= new Element_Type
'(Item);
200 procedure Assign (Target : in out Set; Source : Set) is
202 if Target'Address = Source'Address then
206 Target.Union (Source);
214 function Capacity (Container : Set) return Count_Type is
216 return HT_Ops.Capacity (Container.HT);
223 procedure Clear (Container : in out Set) is
225 HT_Ops.Clear (Container.HT);
228 ------------------------
229 -- Constant_Reference --
230 ------------------------
232 function Constant_Reference
233 (Container : aliased Set;
234 Position : Cursor) return Constant_Reference_Type
237 if Position.Container = null then
238 raise Constraint_Error with "Position cursor has no element";
241 if Position.Container /= Container'Unrestricted_Access then
242 raise Program_Error with
243 "Position cursor designates wrong container";
246 if Position.Node.Element = null then
247 raise Program_Error with "Node has no element";
250 pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
253 HT : Hash_Table_Type renames Position.Container.all.HT;
254 B : Natural renames HT.Busy;
255 L : Natural renames HT.Lock;
257 return R : constant Constant_Reference_Type :=
258 (Element => Position.Node.Element.all'Access,
259 Control => (Controlled with Container'Unrestricted_Access))
265 end Constant_Reference;
271 function Contains (Container : Set; Item : Element_Type) return Boolean is
273 return Find (Container, Item) /= No_Element;
282 Capacity : Count_Type := 0) return Set
290 elsif Capacity >= Source.Length then
295 with "Requested capacity is less than Source length";
298 return Target : Set do
299 Target.Reserve_Capacity (C);
300 Target.Assign (Source);
308 function Copy_Node (Source : Node_Access) return Node_Access is
309 E : Element_Access := new Element_Type'(Source
.Element
.all);
311 return new Node_Type
'(Element => E, Next => null);
323 (Container : in out Set;
329 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
332 raise Constraint_Error with "attempt to delete element not in set";
339 (Container : in out Set;
340 Position : in out Cursor)
343 if Position.Node = null then
344 raise Constraint_Error with "Position cursor equals No_Element";
347 if Position.Node.Element = null then
348 raise Program_Error with "Position cursor is bad";
351 if Position.Container /= Container'Unrestricted_Access then
352 raise Program_Error with "Position cursor designates wrong set";
355 if Container.HT.Busy > 0 then
356 raise Program_Error with
357 "attempt to tamper with cursors (set is busy)";
360 pragma Assert (Vet (Position), "Position cursor is bad");
362 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
364 Free (Position.Node);
365 Position.Container := null;
373 (Target : in out Set;
376 Tgt_Node : Node_Access;
379 if Target'Address = Source'Address then
384 if Source.HT.Length = 0 then
388 if Target.HT.Busy > 0 then
389 raise Program_Error with
390 "attempt to tamper with cursors (set is busy)";
393 if Source.HT.Length < Target.HT.Length then
395 Src_Node : Node_Access;
398 Src_Node := HT_Ops.First (Source.HT);
399 while Src_Node /= null loop
400 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
402 if Tgt_Node /= null then
403 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
407 Src_Node := HT_Ops.Next (Source.HT, Src_Node);
412 Tgt_Node := HT_Ops.First (Target.HT);
413 while Tgt_Node /= null loop
414 if Is_In (Source.HT, Tgt_Node) then
416 X : Node_Access := Tgt_Node;
418 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
419 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
424 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
430 function Difference (Left, Right : Set) return Set is
431 Buckets : HT_Types.Buckets_Access;
435 if Left'Address = Right'Address then
439 if Left.Length = 0 then
443 if Right.Length = 0 then
448 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
450 Buckets := HT_Ops.New_Buckets (Length => Size);
455 Iterate_Left : declare
456 procedure Process (L_Node : Node_Access);
459 new HT_Ops.Generic_Iteration (Process);
465 procedure Process (L_Node : Node_Access) is
467 if not Is_In (Right.HT, L_Node) then
469 Src : Element_Type renames L_Node.Element.all;
470 Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
471 Bucket : Node_Access renames Buckets (Indx);
472 Tgt : Element_Access := new Element_Type'(Src
);
474 Bucket
:= new Node_Type
'(Tgt, Bucket);
481 Length := Length + 1;
485 -- Start of processing for Iterate_Left
491 HT_Ops.Free_Hash_Table (Buckets);
495 return (Controlled with HT => (Buckets, Length, 0, 0));
502 function Element (Position : Cursor) return Element_Type is
504 if Position.Node = null then
505 raise Constraint_Error with "Position cursor of equals No_Element";
508 if Position.Node.Element = null then -- handle dangling reference
509 raise Program_Error with "Position cursor is bad";
512 pragma Assert (Vet (Position), "bad cursor in function Element");
514 return Position.Node.Element.all;
517 ---------------------
518 -- Equivalent_Sets --
519 ---------------------
521 function Equivalent_Sets (Left, Right : Set) return Boolean is
523 return Is_Equivalent (Left.HT, Right.HT);
526 -------------------------
527 -- Equivalent_Elements --
528 -------------------------
530 function Equivalent_Elements (Left, Right : Cursor) return Boolean is
532 if Left.Node = null then
533 raise Constraint_Error with
534 "Left cursor of Equivalent_Elements equals No_Element";
537 if Right.Node = null then
538 raise Constraint_Error with
539 "Right cursor of Equivalent_Elements equals No_Element";
542 if Left.Node.Element = null then
543 raise Program_Error with
544 "Left cursor of Equivalent_Elements is bad";
547 if Right.Node.Element = null then
548 raise Program_Error with
549 "Right cursor of Equivalent_Elements is bad";
552 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
553 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
555 return Equivalent_Elements
556 (Left.Node.Element.all,
557 Right.Node.Element.all);
558 end Equivalent_Elements;
560 function Equivalent_Elements
562 Right : Element_Type) return Boolean
565 if Left.Node = null then
566 raise Constraint_Error with
567 "Left cursor of Equivalent_Elements equals No_Element";
570 if Left.Node.Element = null then
571 raise Program_Error with
572 "Left cursor of Equivalent_Elements is bad";
575 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
577 return Equivalent_Elements (Left.Node.Element.all, Right);
578 end Equivalent_Elements;
580 function Equivalent_Elements
581 (Left : Element_Type;
582 Right : Cursor) return Boolean
585 if Right.Node = null then
586 raise Constraint_Error with
587 "Right cursor of Equivalent_Elements equals No_Element";
590 if Right.Node.Element = null then
591 raise Program_Error with
592 "Right cursor of Equivalent_Elements is bad";
595 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
597 return Equivalent_Elements (Left, Right.Node.Element.all);
598 end Equivalent_Elements;
600 ---------------------
601 -- Equivalent_Keys --
602 ---------------------
604 function Equivalent_Keys
606 Node : Node_Access) return Boolean
609 return Equivalent_Elements (Key, Node.Element.all);
617 (Container : in out Set;
622 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
630 procedure Finalize (Container : in out Set) is
632 HT_Ops.Finalize (Container.HT);
635 procedure Finalize (Object : in out Iterator) is
637 if Object.Container /= null then
639 B : Natural renames Object.Container.all.HT.Busy;
646 procedure Finalize (Control : in out Reference_Control_Type) is
648 if Control.Container /= null then
650 HT : Hash_Table_Type renames Control.Container.all.HT;
651 B : Natural renames HT.Busy;
652 L : Natural renames HT.Lock;
658 Control.Container := null;
668 Item : Element_Type) return Cursor
670 Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
672 return (if Node = null then No_Element
673 else Cursor'(Container
'Unrestricted_Access, Node
));
680 function Find_Equal_Key
681 (R_HT
: Hash_Table_Type
;
682 L_Node
: Node_Access
) return Boolean
684 R_Index
: constant Hash_Type
:=
685 Element_Keys
.Index
(R_HT
, L_Node
.Element
.all);
687 R_Node
: Node_Access
:= R_HT
.Buckets
(R_Index
);
691 if R_Node
= null then
695 if L_Node
.Element
.all = R_Node
.Element
.all then
699 R_Node
:= Next
(R_Node
);
703 -------------------------
704 -- Find_Equivalent_Key --
705 -------------------------
707 function Find_Equivalent_Key
708 (R_HT
: Hash_Table_Type
;
709 L_Node
: Node_Access
) return Boolean
711 R_Index
: constant Hash_Type
:=
712 Element_Keys
.Index
(R_HT
, L_Node
.Element
.all);
714 R_Node
: Node_Access
:= R_HT
.Buckets
(R_Index
);
718 if R_Node
= null then
722 if Equivalent_Elements
(L_Node
.Element
.all, R_Node
.Element
.all) then
726 R_Node
:= Next
(R_Node
);
728 end Find_Equivalent_Key
;
734 function First
(Container
: Set
) return Cursor
is
735 Node
: constant Node_Access
:= HT_Ops
.First
(Container
.HT
);
737 return (if Node
= null then No_Element
738 else Cursor
'(Container'Unrestricted_Access, Node));
741 function First (Object : Iterator) return Cursor is
743 return Object.Container.First;
750 procedure Free (X : in out Node_Access) is
751 procedure Deallocate is
752 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
759 X.Next := X; -- detect mischief (in Vet)
762 Free_Element (X.Element);
777 function Has_Element (Position : Cursor) return Boolean is
779 pragma Assert (Vet (Position), "bad cursor in Has_Element");
780 return Position.Node /= null;
787 function Hash_Node (Node : Node_Access) return Hash_Type is
789 return Hash (Node.Element.all);
797 (Container : in out Set;
798 New_Item : Element_Type)
806 Insert (Container, New_Item, Position, Inserted);
809 if Container.HT.Lock > 0 then
810 raise Program_Error with
811 "attempt to tamper with elements (set is locked)";
814 X := Position.Node.Element;
817 -- The element allocator may need an accessibility check in the
818 -- case the actual type is class-wide or has access discriminants
819 -- (see RM 4.8(10.1) and AI12-0035).
821 pragma Unsuppress (Accessibility_Check);
824 Position.Node.Element := new Element_Type'(New_Item
);
836 (Container
: in out Set
;
837 New_Item
: Element_Type
;
838 Position
: out Cursor
;
839 Inserted
: out Boolean)
842 Insert
(Container
.HT
, New_Item
, Position
.Node
, Inserted
);
843 Position
.Container
:= Container
'Unchecked_Access;
847 (Container
: in out Set
;
848 New_Item
: Element_Type
)
851 pragma Unreferenced
(Position
);
856 Insert
(Container
, New_Item
, Position
, Inserted
);
859 raise Constraint_Error
with
860 "attempt to insert element already in set";
865 (HT
: in out Hash_Table_Type
;
866 New_Item
: Element_Type
;
867 Node
: out Node_Access
;
868 Inserted
: out Boolean)
870 function New_Node
(Next
: Node_Access
) return Node_Access
;
871 pragma Inline
(New_Node
);
873 procedure Local_Insert
is
874 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
880 function New_Node
(Next
: Node_Access
) return Node_Access
is
882 -- The element allocator may need an accessibility check in the case
883 -- the actual type is class-wide or has access discriminants (see
884 -- RM 4.8(10.1) and AI12-0035).
886 pragma Unsuppress
(Accessibility_Check
);
888 Element
: Element_Access
:= new Element_Type
'(New_Item);
891 return new Node_Type'(Element
, Next
);
895 Free_Element
(Element
);
899 -- Start of processing for Insert
902 if HT_Ops
.Capacity
(HT
) = 0 then
903 HT_Ops
.Reserve_Capacity
(HT
, 1);
906 Local_Insert
(HT
, New_Item
, Node
, Inserted
);
908 if Inserted
and then HT
.Length
> HT_Ops
.Capacity
(HT
) then
909 HT_Ops
.Reserve_Capacity
(HT
, HT
.Length
);
917 procedure Intersection
918 (Target
: in out Set
;
921 Tgt_Node
: Node_Access
;
924 if Target
'Address = Source
'Address then
928 if Source
.Length
= 0 then
933 if Target
.HT
.Busy
> 0 then
934 raise Program_Error
with
935 "attempt to tamper with cursors (set is busy)";
938 Tgt_Node
:= HT_Ops
.First
(Target
.HT
);
939 while Tgt_Node
/= null loop
940 if Is_In
(Source
.HT
, Tgt_Node
) then
941 Tgt_Node
:= HT_Ops
.Next
(Target
.HT
, Tgt_Node
);
945 X
: Node_Access
:= Tgt_Node
;
947 Tgt_Node
:= HT_Ops
.Next
(Target
.HT
, Tgt_Node
);
948 HT_Ops
.Delete_Node_Sans_Free
(Target
.HT
, X
);
955 function Intersection
(Left
, Right
: Set
) return Set
is
956 Buckets
: HT_Types
.Buckets_Access
;
960 if Left
'Address = Right
'Address then
964 Length
:= Count_Type
'Min (Left
.Length
, Right
.Length
);
971 Size
: constant Hash_Type
:= Prime_Numbers
.To_Prime
(Length
);
973 Buckets
:= HT_Ops
.New_Buckets
(Length
=> Size
);
978 Iterate_Left
: declare
979 procedure Process
(L_Node
: Node_Access
);
982 new HT_Ops
.Generic_Iteration
(Process
);
988 procedure Process
(L_Node
: Node_Access
) is
990 if Is_In
(Right
.HT
, L_Node
) then
992 Src
: Element_Type
renames L_Node
.Element
.all;
994 Indx
: constant Hash_Type
:= Hash
(Src
) mod Buckets
'Length;
996 Bucket
: Node_Access
renames Buckets
(Indx
);
998 Tgt
: Element_Access
:= new Element_Type
'(Src);
1001 Bucket := new Node_Type'(Tgt
, Bucket
);
1008 Length
:= Length
+ 1;
1012 -- Start of processing for Iterate_Left
1018 HT_Ops
.Free_Hash_Table
(Buckets
);
1022 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
1029 function Is_Empty
(Container
: Set
) return Boolean is
1031 return Container
.HT
.Length
= 0;
1038 function Is_In
(HT
: Hash_Table_Type
; Key
: Node_Access
) return Boolean is
1040 return Element_Keys
.Find
(HT
, Key
.Element
.all) /= null;
1049 Of_Set
: Set
) return Boolean
1051 Subset_Node
: Node_Access
;
1054 if Subset
'Address = Of_Set
'Address then
1058 if Subset
.Length
> Of_Set
.Length
then
1062 Subset_Node
:= HT_Ops
.First
(Subset
.HT
);
1063 while Subset_Node
/= null loop
1064 if not Is_In
(Of_Set
.HT
, Subset_Node
) then
1068 Subset_Node
:= HT_Ops
.Next
(Subset
.HT
, Subset_Node
);
1080 Process
: not null access procedure (Position
: Cursor
))
1082 procedure Process_Node
(Node
: Node_Access
);
1083 pragma Inline
(Process_Node
);
1085 procedure Iterate
is
1086 new HT_Ops
.Generic_Iteration
(Process_Node
);
1092 procedure Process_Node
(Node
: Node_Access
) is
1094 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1097 B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1099 -- Start of processing for Iterate
1105 Iterate (Container.HT);
1115 function Iterate (Container : Set)
1116 return Set_Iterator_Interfaces.Forward_Iterator'Class
1118 B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1120 return It : constant Iterator :=
1121 Iterator'(Limited_Controlled
with
1122 Container
=> Container
'Unrestricted_Access)
1132 function Length
(Container
: Set
) return Count_Type
is
1134 return Container
.HT
.Length
;
1141 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1143 HT_Ops
.Move
(Target
=> Target
.HT
, Source
=> Source
.HT
);
1150 function Next
(Node
: Node_Access
) return Node_Access
is
1155 function Next
(Position
: Cursor
) return Cursor
is
1157 if Position
.Node
= null then
1161 if Position
.Node
.Element
= null then
1162 raise Program_Error
with "bad cursor in Next";
1165 pragma Assert
(Vet
(Position
), "bad cursor in Next");
1168 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
1169 Node
: constant Node_Access
:= HT_Ops
.Next
(HT
, Position
.Node
);
1171 return (if Node
= null then No_Element
1172 else Cursor
'(Position.Container, Node));
1176 procedure Next (Position : in out Cursor) is
1178 Position := Next (Position);
1183 Position : Cursor) return Cursor
1186 if Position.Container = null then
1190 if Position.Container /= Object.Container then
1191 raise Program_Error with
1192 "Position cursor of Next designates wrong set";
1195 return Next (Position);
1202 function Overlap (Left, Right : Set) return Boolean is
1203 Left_Node : Node_Access;
1206 if Right.Length = 0 then
1210 if Left'Address = Right'Address then
1214 Left_Node := HT_Ops.First (Left.HT);
1215 while Left_Node /= null loop
1216 if Is_In (Right.HT, Left_Node) then
1220 Left_Node := HT_Ops.Next (Left.HT, Left_Node);
1230 procedure Query_Element
1232 Process : not null access procedure (Element : Element_Type))
1235 if Position.Node = null then
1236 raise Constraint_Error with
1237 "Position cursor of Query_Element equals No_Element";
1240 if Position.Node.Element = null then
1241 raise Program_Error with "bad cursor in Query_Element";
1244 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1247 HT : Hash_Table_Type renames
1248 Position.Container'Unrestricted_Access.all.HT;
1250 B : Natural renames HT.Busy;
1251 L : Natural renames HT.Lock;
1258 Process (Position.Node.Element.all);
1276 (Stream : not null access Root_Stream_Type'Class;
1277 Container : out Set)
1280 Read_Nodes (Stream, Container.HT);
1284 (Stream : not null access Root_Stream_Type'Class;
1288 raise Program_Error with "attempt to stream set cursor";
1292 (Stream : not null access Root_Stream_Type'Class;
1293 Item : out Constant_Reference_Type)
1296 raise Program_Error with "attempt to stream reference";
1304 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1306 X : Element_Access := new Element_Type'(Element_Type
'Input (Stream
));
1308 return new Node_Type
'(X, null);
1320 (Container : in out Set;
1321 New_Item : Element_Type)
1323 Node : constant Node_Access :=
1324 Element_Keys.Find (Container.HT, New_Item);
1327 pragma Warnings (Off, X);
1331 raise Constraint_Error with
1332 "attempt to replace element not in set";
1335 if Container.HT.Lock > 0 then
1336 raise Program_Error with
1337 "attempt to tamper with elements (set is locked)";
1343 -- The element allocator may need an accessibility check in the case
1344 -- the actual type is class-wide or has access discriminants (see
1345 -- RM 4.8(10.1) and AI12-0035).
1347 pragma Unsuppress (Accessibility_Check);
1350 Node.Element := new Element_Type'(New_Item
);
1356 ---------------------
1357 -- Replace_Element --
1358 ---------------------
1360 procedure Replace_Element
1361 (Container
: in out Set
;
1363 New_Item
: Element_Type
)
1366 if Position
.Node
= null then
1367 raise Constraint_Error
with "Position cursor equals No_Element";
1370 if Position
.Node
.Element
= null then
1371 raise Program_Error
with "bad cursor in Replace_Element";
1374 if Position
.Container
/= Container
'Unrestricted_Access then
1375 raise Program_Error
with
1376 "Position cursor designates wrong set";
1379 pragma Assert
(Vet
(Position
), "bad cursor in Replace_Element");
1381 Replace_Element
(Container
.HT
, Position
.Node
, New_Item
);
1382 end Replace_Element
;
1384 ----------------------
1385 -- Reserve_Capacity --
1386 ----------------------
1388 procedure Reserve_Capacity
1389 (Container
: in out Set
;
1390 Capacity
: Count_Type
)
1393 HT_Ops
.Reserve_Capacity
(Container
.HT
, Capacity
);
1394 end Reserve_Capacity
;
1400 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
) is
1405 --------------------------
1406 -- Symmetric_Difference --
1407 --------------------------
1409 procedure Symmetric_Difference
1410 (Target
: in out Set
;
1414 if Target
'Address = Source
'Address then
1419 if Target
.HT
.Busy
> 0 then
1420 raise Program_Error
with
1421 "attempt to tamper with cursors (set is busy)";
1425 N
: constant Count_Type
:= Target
.Length
+ Source
.Length
;
1427 if N
> HT_Ops
.Capacity
(Target
.HT
) then
1428 HT_Ops
.Reserve_Capacity
(Target
.HT
, N
);
1432 if Target
.Length
= 0 then
1433 Iterate_Source_When_Empty_Target
: declare
1434 procedure Process
(Src_Node
: Node_Access
);
1436 procedure Iterate
is new HT_Ops
.Generic_Iteration
(Process
);
1442 procedure Process
(Src_Node
: Node_Access
) is
1443 E
: Element_Type
renames Src_Node
.Element
.all;
1444 B
: Buckets_Type
renames Target
.HT
.Buckets
.all;
1445 J
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
1446 N
: Count_Type
renames Target
.HT
.Length
;
1450 X
: Element_Access
:= new Element_Type
'(E);
1452 B (J) := new Node_Type'(X
, B
(J
));
1462 -- Start of processing for Iterate_Source_When_Empty_Target
1465 Iterate
(Source
.HT
);
1466 end Iterate_Source_When_Empty_Target
;
1469 Iterate_Source
: declare
1470 procedure Process
(Src_Node
: Node_Access
);
1472 procedure Iterate
is
1473 new HT_Ops
.Generic_Iteration
(Process
);
1479 procedure Process
(Src_Node
: Node_Access
) is
1480 E
: Element_Type
renames Src_Node
.Element
.all;
1481 B
: Buckets_Type
renames Target
.HT
.Buckets
.all;
1482 J
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
1483 N
: Count_Type
renames Target
.HT
.Length
;
1486 if B
(J
) = null then
1488 X
: Element_Access
:= new Element_Type
'(E);
1490 B (J) := new Node_Type'(X
, null);
1499 elsif Equivalent_Elements
(E
, B
(J
).Element
.all) then
1501 X
: Node_Access
:= B
(J
);
1503 B
(J
) := B
(J
).Next
;
1510 Prev
: Node_Access
:= B
(J
);
1511 Curr
: Node_Access
:= Prev
.Next
;
1514 while Curr
/= null loop
1515 if Equivalent_Elements
(E
, Curr
.Element
.all) then
1516 Prev
.Next
:= Curr
.Next
;
1527 X
: Element_Access
:= new Element_Type
'(E);
1529 B (J) := new Node_Type'(X
, B
(J
));
1541 -- Start of processing for Iterate_Source
1544 Iterate
(Source
.HT
);
1547 end Symmetric_Difference
;
1549 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
1550 Buckets
: HT_Types
.Buckets_Access
;
1551 Length
: Count_Type
;
1554 if Left
'Address = Right
'Address then
1558 if Right
.Length
= 0 then
1562 if Left
.Length
= 0 then
1567 Size
: constant Hash_Type
:=
1568 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1570 Buckets
:= HT_Ops
.New_Buckets
(Length
=> Size
);
1575 Iterate_Left
: declare
1576 procedure Process
(L_Node
: Node_Access
);
1578 procedure Iterate
is
1579 new HT_Ops
.Generic_Iteration
(Process
);
1585 procedure Process
(L_Node
: Node_Access
) is
1587 if not Is_In
(Right
.HT
, L_Node
) then
1589 E
: Element_Type
renames L_Node
.Element
.all;
1590 J
: constant Hash_Type
:= Hash
(E
) mod Buckets
'Length;
1594 X
: Element_Access
:= new Element_Type
'(E);
1596 Buckets (J) := new Node_Type'(X
, Buckets
(J
));
1603 Length
:= Length
+ 1;
1608 -- Start of processing for Iterate_Left
1614 HT_Ops
.Free_Hash_Table
(Buckets
);
1618 Iterate_Right
: declare
1619 procedure Process
(R_Node
: Node_Access
);
1621 procedure Iterate
is
1622 new HT_Ops
.Generic_Iteration
(Process
);
1628 procedure Process
(R_Node
: Node_Access
) is
1630 if not Is_In
(Left
.HT
, R_Node
) then
1632 E
: Element_Type
renames R_Node
.Element
.all;
1633 J
: constant Hash_Type
:= Hash
(E
) mod Buckets
'Length;
1637 X
: Element_Access
:= new Element_Type
'(E);
1639 Buckets (J) := new Node_Type'(X
, Buckets
(J
));
1646 Length
:= Length
+ 1;
1651 -- Start of processing for Iterate_Right
1657 HT_Ops
.Free_Hash_Table
(Buckets
);
1661 return (Controlled
with HT
=> (Buckets
, Length
, 0, 0));
1662 end Symmetric_Difference
;
1668 function To_Set
(New_Item
: Element_Type
) return Set
is
1669 HT
: Hash_Table_Type
;
1672 pragma Unreferenced
(Node
, Inserted
);
1674 Insert
(HT
, New_Item
, Node
, Inserted
);
1675 return Set
'(Controlled with HT);
1683 (Target : in out Set;
1686 procedure Process (Src_Node : Node_Access);
1688 procedure Iterate is
1689 new HT_Ops.Generic_Iteration (Process);
1695 procedure Process (Src_Node : Node_Access) is
1696 Src : Element_Type renames Src_Node.Element.all;
1698 function New_Node (Next : Node_Access) return Node_Access;
1699 pragma Inline (New_Node);
1702 new Element_Keys.Generic_Conditional_Insert (New_Node);
1708 function New_Node (Next : Node_Access) return Node_Access is
1709 Tgt : Element_Access := new Element_Type'(Src
);
1711 return new Node_Type
'(Tgt, Next);
1718 Tgt_Node : Node_Access;
1720 pragma Unreferenced (Tgt_Node, Success);
1722 -- Start of processing for Process
1725 Insert (Target.HT, Src, Tgt_Node, Success);
1728 -- Start of processing for Union
1731 if Target'Address = Source'Address then
1735 if Target.HT.Busy > 0 then
1736 raise Program_Error with
1737 "attempt to tamper with cursors (set is busy)";
1741 N : constant Count_Type := Target.Length + Source.Length;
1743 if N > HT_Ops.Capacity (Target.HT) then
1744 HT_Ops.Reserve_Capacity (Target.HT, N);
1748 Iterate (Source.HT);
1751 function Union (Left, Right : Set) return Set is
1752 Buckets : HT_Types.Buckets_Access;
1753 Length : Count_Type;
1756 if Left'Address = Right'Address then
1760 if Right.Length = 0 then
1764 if Left.Length = 0 then
1769 Size : constant Hash_Type :=
1770 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1772 Buckets := HT_Ops.New_Buckets (Length => Size);
1775 Iterate_Left : declare
1776 procedure Process (L_Node : Node_Access);
1778 procedure Iterate is
1779 new HT_Ops.Generic_Iteration (Process);
1785 procedure Process (L_Node : Node_Access) is
1786 Src : Element_Type renames L_Node.Element.all;
1787 J : constant Hash_Type := Hash (Src) mod Buckets'Length;
1788 Bucket : Node_Access renames Buckets (J);
1789 Tgt : Element_Access := new Element_Type'(Src
);
1791 Bucket
:= new Node_Type
'(Tgt, Bucket);
1798 -- Start of processing for Process
1804 HT_Ops.Free_Hash_Table (Buckets);
1808 Length := Left.Length;
1810 Iterate_Right : declare
1811 procedure Process (Src_Node : Node_Access);
1813 procedure Iterate is
1814 new HT_Ops.Generic_Iteration (Process);
1820 procedure Process (Src_Node : Node_Access) is
1821 Src : Element_Type renames Src_Node.Element.all;
1822 Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
1824 Tgt_Node : Node_Access := Buckets (Idx);
1827 while Tgt_Node /= null loop
1828 if Equivalent_Elements (Src, Tgt_Node.Element.all) then
1831 Tgt_Node := Next (Tgt_Node);
1835 Tgt : Element_Access := new Element_Type'(Src
);
1837 Buckets
(Idx
) := new Node_Type
'(Tgt, Buckets (Idx));
1844 Length := Length + 1;
1847 -- Start of processing for Iterate_Right
1853 HT_Ops.Free_Hash_Table (Buckets);
1857 return (Controlled with HT => (Buckets, Length, 0, 0));
1864 function Vet (Position : Cursor) return Boolean is
1866 if Position.Node = null then
1867 return Position.Container = null;
1870 if Position.Container = null then
1874 if Position.Node.Next = Position.Node then
1878 if Position.Node.Element = null then
1883 HT : Hash_Table_Type renames Position.Container.HT;
1887 if HT.Length = 0 then
1891 if HT.Buckets = null
1892 or else HT.Buckets'Length = 0
1897 X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
1899 for J in 1 .. HT.Length loop
1900 if X = Position.Node then
1908 if X = X.Next then -- to prevent unnecessary looping
1924 (Stream : not null access Root_Stream_Type'Class;
1928 Write_Nodes (Stream, Container.HT);
1932 (Stream : not null access Root_Stream_Type'Class;
1936 raise Program_Error with "attempt to stream set cursor";
1940 (Stream : not null access Root_Stream_Type'Class;
1941 Item : Constant_Reference_Type)
1944 raise Program_Error with "attempt to stream reference";
1951 procedure Write_Node
1952 (Stream : not null access Root_Stream_Type'Class;
1956 Element_Type'Output (Stream, Node.Element.all);
1959 package body Generic_Keys is
1961 -----------------------
1962 -- Local Subprograms --
1963 -----------------------
1965 function Equivalent_Key_Node
1967 Node : Node_Access) return Boolean;
1968 pragma Inline (Equivalent_Key_Node);
1970 --------------------------
1971 -- Local Instantiations --
1972 --------------------------
1975 new Hash_Tables.Generic_Keys
1976 (HT_Types => HT_Types,
1978 Set_Next => Set_Next,
1979 Key_Type => Key_Type,
1981 Equivalent_Keys => Equivalent_Key_Node);
1983 ------------------------
1984 -- Constant_Reference --
1985 ------------------------
1987 function Constant_Reference
1988 (Container : aliased Set;
1989 Key : Key_Type) return Constant_Reference_Type
1991 Node : constant Node_Access :=
1992 Key_Keys.Find (Container.HT, Key);
1996 raise Constraint_Error with "Key not in set";
1999 if Node.Element = null then
2000 raise Program_Error with "Node has no element";
2004 HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
2005 B : Natural renames HT.Busy;
2006 L : Natural renames HT.Lock;
2008 return R : constant Constant_Reference_Type :=
2009 (Element => Node.Element.all'Access,
2010 Control => (Controlled with Container'Unrestricted_Access))
2016 end Constant_Reference;
2024 Key : Key_Type) return Boolean
2027 return Find (Container, Key) /= No_Element;
2035 (Container : in out Set;
2041 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2044 raise Constraint_Error with "key not in map"; -- ??? "set"
2056 Key : Key_Type) return Element_Type
2058 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2062 raise Constraint_Error with "key not in map"; -- ??? "set"
2065 return Node.Element.all;
2068 -------------------------
2069 -- Equivalent_Key_Node --
2070 -------------------------
2072 function Equivalent_Key_Node
2074 Node : Node_Access) return Boolean is
2076 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
2077 end Equivalent_Key_Node;
2084 (Container : in out Set;
2089 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2099 Key : Key_Type) return Cursor
2101 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2103 return (if Node = null then No_Element
2104 else Cursor'(Container
'Unrestricted_Access, Node
));
2111 function Key
(Position
: Cursor
) return Key_Type
is
2113 if Position
.Node
= null then
2114 raise Constraint_Error
with
2115 "Position cursor equals No_Element";
2118 if Position
.Node
.Element
= null then
2119 raise Program_Error
with "Position cursor is bad";
2122 pragma Assert
(Vet
(Position
), "bad cursor in function Key");
2124 return Key
(Position
.Node
.Element
.all);
2132 (Stream
: not null access Root_Stream_Type
'Class;
2133 Item
: out Reference_Type
)
2136 raise Program_Error
with "attempt to stream reference";
2139 ------------------------------
2140 -- Reference_Preserving_Key --
2141 ------------------------------
2143 function Reference_Preserving_Key
2144 (Container
: aliased in out Set
;
2145 Position
: Cursor
) return Reference_Type
2148 if Position
.Container
= null then
2149 raise Constraint_Error
with "Position cursor has no element";
2152 if Position
.Container
/= Container
'Unrestricted_Access then
2153 raise Program_Error
with
2154 "Position cursor designates wrong container";
2157 if Position
.Node
.Element
= null then
2158 raise Program_Error
with "Node has no element";
2163 "bad cursor in function Reference_Preserving_Key");
2165 -- Some form of finalization will be required in order to actually
2166 -- check that the key-part of the element designated by Position has
2169 return (Element
=> Position
.Node
.Element
.all'Access);
2170 end Reference_Preserving_Key
;
2172 function Reference_Preserving_Key
2173 (Container
: aliased in out Set
;
2174 Key
: Key_Type
) return Reference_Type
2176 Node
: constant Node_Access
:=
2177 Key_Keys
.Find
(Container
.HT
, Key
);
2181 raise Constraint_Error
with "Key not in set";
2184 if Node
.Element
= null then
2185 raise Program_Error
with "Node has no element";
2188 -- Some form of finalization will be required in order to actually
2189 -- check that the key-part of the element designated by Key has not
2192 return (Element
=> Node
.Element
.all'Access);
2193 end Reference_Preserving_Key
;
2200 (Container
: in out Set
;
2202 New_Item
: Element_Type
)
2204 Node
: constant Node_Access
:=
2205 Key_Keys
.Find
(Container
.HT
, Key
);
2209 raise Constraint_Error
with
2210 "attempt to replace key not in set";
2213 Replace_Element
(Container
.HT
, Node
, New_Item
);
2216 -----------------------------------
2217 -- Update_Element_Preserving_Key --
2218 -----------------------------------
2220 procedure Update_Element_Preserving_Key
2221 (Container
: in out Set
;
2223 Process
: not null access
2224 procedure (Element
: in out Element_Type
))
2226 HT
: Hash_Table_Type
renames Container
.HT
;
2230 if Position
.Node
= null then
2231 raise Constraint_Error
with
2232 "Position cursor equals No_Element";
2235 if Position
.Node
.Element
= null
2236 or else Position
.Node
.Next
= Position
.Node
2238 raise Program_Error
with "Position cursor is bad";
2241 if Position
.Container
/= Container
'Unrestricted_Access then
2242 raise Program_Error
with
2243 "Position cursor designates wrong set";
2246 if HT
.Buckets
= null
2247 or else HT
.Buckets
'Length = 0
2248 or else HT
.Length
= 0
2250 raise Program_Error
with "Position cursor is bad (set is empty)";
2255 "bad cursor in Update_Element_Preserving_Key");
2257 Indx
:= HT_Ops
.Index
(HT
, Position
.Node
);
2260 E
: Element_Type
renames Position
.Node
.Element
.all;
2261 K
: constant Key_Type
:= Key
(E
);
2263 B
: Natural renames HT
.Busy
;
2264 L
: Natural renames HT
.Lock
;
2282 if Equivalent_Keys
(K
, Key
(E
)) then
2283 pragma Assert
(Hash
(K
) = Hash
(E
));
2288 if HT
.Buckets
(Indx
) = Position
.Node
then
2289 HT
.Buckets
(Indx
) := Position
.Node
.Next
;
2293 Prev
: Node_Access
:= HT
.Buckets
(Indx
);
2296 while Prev
.Next
/= Position
.Node
loop
2300 raise Program_Error
with
2301 "Position cursor is bad (node not found)";
2305 Prev
.Next
:= Position
.Node
.Next
;
2309 HT
.Length
:= HT
.Length
- 1;
2312 X
: Node_Access
:= Position
.Node
;
2318 raise Program_Error
with "key was modified";
2319 end Update_Element_Preserving_Key
;
2326 (Stream
: not null access Root_Stream_Type
'Class;
2327 Item
: Reference_Type
)
2330 raise Program_Error
with "attempt to stream reference";
2335 end Ada
.Containers
.Indefinite_Hashed_Sets
;