1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_HASHED_SETS --
9 -- Copyright (C) 2004-2014, 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 pragma Annotate (CodePeer, Skip_Analysis);
46 -----------------------
47 -- Local Subprograms --
48 -----------------------
50 procedure Assign (Node : Node_Access; Item : Element_Type);
51 pragma Inline (Assign);
53 function Copy_Node (Source : Node_Access) return Node_Access;
54 pragma Inline (Copy_Node);
56 function Equivalent_Keys
58 Node : Node_Access) return Boolean;
59 pragma Inline (Equivalent_Keys);
61 function Find_Equal_Key
62 (R_HT : Hash_Table_Type;
63 L_Node : Node_Access) return Boolean;
65 function Find_Equivalent_Key
66 (R_HT : Hash_Table_Type;
67 L_Node : Node_Access) return Boolean;
69 procedure Free (X : in out Node_Access);
71 function Hash_Node (Node : Node_Access) return Hash_Type;
72 pragma Inline (Hash_Node);
75 (HT : in out Hash_Table_Type;
76 New_Item : Element_Type;
77 Node : out Node_Access;
78 Inserted : out Boolean);
81 (HT : aliased in out Hash_Table_Type;
82 Key : Node_Access) return Boolean;
83 pragma Inline (Is_In);
85 function Next (Node : Node_Access) return Node_Access;
88 function Read_Node (Stream : not null access Root_Stream_Type'Class)
90 pragma Inline (Read_Node);
92 procedure Set_Next (Node : Node_Access; Next : Node_Access);
93 pragma Inline (Set_Next);
95 function Vet (Position : Cursor) return Boolean;
98 (Stream : not null access Root_Stream_Type'Class;
100 pragma Inline (Write_Node);
102 --------------------------
103 -- Local Instantiations --
104 --------------------------
106 procedure Free_Element is
107 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
109 package HT_Ops is new Hash_Tables.Generic_Operations
110 (HT_Types => HT_Types,
111 Hash_Node => Hash_Node,
113 Set_Next => Set_Next,
114 Copy_Node => Copy_Node,
117 package Element_Keys is new Hash_Tables.Generic_Keys
118 (HT_Types => HT_Types,
120 Set_Next => Set_Next,
121 Key_Type => Element_Type,
123 Equivalent_Keys => Equivalent_Keys);
126 new HT_Ops.Generic_Equal (Find_Equal_Key);
128 function Is_Equivalent is
129 new HT_Ops.Generic_Equal (Find_Equivalent_Key);
131 procedure Read_Nodes is
132 new HT_Ops.Generic_Read (Read_Node);
134 procedure Replace_Element is
135 new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
137 procedure Write_Nodes is
138 new HT_Ops.Generic_Write (Write_Node);
144 function "=" (Left, Right : Set) return Boolean is
146 return Is_Equal (Left.HT, Right.HT);
153 procedure Adjust (Container : in out Set) is
155 HT_Ops.Adjust (Container.HT);
158 procedure Adjust (Control : in out Reference_Control_Type) is
160 if Control.Container /= null then
162 HT : Hash_Table_Type renames Control.Container.all.HT;
163 B : Natural renames HT.Busy;
164 L : Natural renames HT.Lock;
176 procedure Assign (Node : Node_Access; Item : Element_Type) is
177 X : Element_Access := Node.Element;
179 -- The element allocator may need an accessibility check in the case the
180 -- actual type is class-wide or has access discriminants (RM 4.8(10.1)
183 pragma Unsuppress (Accessibility_Check);
186 Node.Element := new Element_Type'(Item);
190 procedure Assign (Target : in out Set; Source : Set) is
192 if Target'Address = Source'Address then
196 Target.Union (Source);
204 function Capacity (Container : Set) return Count_Type is
206 return HT_Ops.Capacity (Container.HT);
213 procedure Clear (Container : in out Set) is
215 HT_Ops.Clear (Container.HT);
218 ------------------------
219 -- Constant_Reference --
220 ------------------------
222 function Constant_Reference
223 (Container : aliased Set;
224 Position : Cursor) return Constant_Reference_Type
227 if Position.Container = null then
228 raise Constraint_Error with "Position cursor has no element";
231 if Position.Container /= Container'Unrestricted_Access then
232 raise Program_Error with
233 "Position cursor designates wrong container";
236 if Position.Node.Element = null then
237 raise Program_Error with "Node has no element";
240 pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
243 HT : Hash_Table_Type renames Position.Container.all.HT;
244 B : Natural renames HT.Busy;
245 L : Natural renames HT.Lock;
247 return R : constant Constant_Reference_Type :=
248 (Element => Position.Node.Element.all'Access,
249 Control => (Controlled with Container'Unrestricted_Access))
255 end Constant_Reference;
261 function Contains (Container : Set; Item : Element_Type) return Boolean is
263 return Find (Container, Item) /= No_Element;
272 Capacity : Count_Type := 0) return Set
280 elsif Capacity >= Source.Length then
285 with "Requested capacity is less than Source length";
288 return Target : Set do
289 Target.Reserve_Capacity (C);
290 Target.Assign (Source);
298 function Copy_Node (Source : Node_Access) return Node_Access is
299 E : Element_Access := new Element_Type'(Source.Element.all);
301 return new Node_Type'(Element => E, Next => null);
313 (Container : in out Set;
319 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
322 raise Constraint_Error with "attempt to delete element not in set";
329 (Container : in out Set;
330 Position : in out Cursor)
333 if Position.Node = null then
334 raise Constraint_Error with "Position cursor equals No_Element";
337 if Position.Node.Element = null then
338 raise Program_Error with "Position cursor is bad";
341 if Position.Container /= Container'Unrestricted_Access then
342 raise Program_Error with "Position cursor designates wrong set";
345 if Container.HT.Busy > 0 then
346 raise Program_Error with
347 "attempt to tamper with cursors (set is busy)";
350 pragma Assert (Vet (Position), "Position cursor is bad");
352 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
354 Free (Position.Node);
355 Position.Container := null;
363 (Target : in out Set;
366 Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT;
367 Tgt_Node : Node_Access;
370 if Target'Address = Source'Address then
375 if Src_HT.Length = 0 then
379 if Target.HT.Busy > 0 then
380 raise Program_Error with
381 "attempt to tamper with cursors (set is busy)";
384 if Src_HT.Length < Target.HT.Length then
386 Src_Node : Node_Access;
389 Src_Node := HT_Ops.First (Src_HT);
390 while Src_Node /= null loop
391 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
393 if Tgt_Node /= null then
394 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
398 Src_Node := HT_Ops.Next (Src_HT, Src_Node);
403 Tgt_Node := HT_Ops.First (Target.HT);
404 while Tgt_Node /= null loop
405 if Is_In (Src_HT, Tgt_Node) then
407 X : Node_Access := Tgt_Node;
409 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
410 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
415 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
421 function Difference (Left, Right : Set) return Set is
422 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
423 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
424 Buckets : HT_Types.Buckets_Access;
428 if Left'Address = Right'Address then
432 if Left.Length = 0 then
436 if Right.Length = 0 then
441 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
443 Buckets := HT_Ops.New_Buckets (Length => Size);
448 Iterate_Left : declare
449 procedure Process (L_Node : Node_Access);
452 new HT_Ops.Generic_Iteration (Process);
458 procedure Process (L_Node : Node_Access) is
460 if not Is_In (Right_HT, L_Node) then
462 -- Per AI05-0022, the container implementation is required
463 -- to detect element tampering by a generic actual
464 -- subprogram, hence the use of Checked_Index instead of a
465 -- simple invocation of generic formal Hash.
467 Indx : constant Hash_Type :=
468 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
470 Bucket : Node_Access renames Buckets (Indx);
471 Src : Element_Type renames L_Node.Element.all;
472 Tgt : Element_Access := new Element_Type'(Src);
475 Bucket := new Node_Type'(Tgt, Bucket);
483 Length := Length + 1;
487 -- Start of processing for Iterate_Left
494 HT_Ops.Free_Hash_Table (Buckets);
498 return (Controlled with HT => (Buckets, Length, 0, 0));
505 function Element (Position : Cursor) return Element_Type is
507 if Position.Node = null then
508 raise Constraint_Error with "Position cursor of equals No_Element";
511 if Position.Node.Element = null then -- handle dangling reference
512 raise Program_Error with "Position cursor is bad";
515 pragma Assert (Vet (Position), "bad cursor in function Element");
517 return Position.Node.Element.all;
520 ---------------------
521 -- Equivalent_Sets --
522 ---------------------
524 function Equivalent_Sets (Left, Right : Set) return Boolean is
526 return Is_Equivalent (Left.HT, Right.HT);
529 -------------------------
530 -- Equivalent_Elements --
531 -------------------------
533 function Equivalent_Elements (Left, Right : Cursor) return Boolean is
535 if Left.Node = null then
536 raise Constraint_Error with
537 "Left cursor of Equivalent_Elements equals No_Element";
540 if Right.Node = null then
541 raise Constraint_Error with
542 "Right cursor of Equivalent_Elements equals No_Element";
545 if Left.Node.Element = null then
546 raise Program_Error with
547 "Left cursor of Equivalent_Elements is bad";
550 if Right.Node.Element = null then
551 raise Program_Error with
552 "Right cursor of Equivalent_Elements is bad";
555 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
556 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
558 -- AI05-0022 requires that a container implementation detect element
559 -- tampering by a generic actual subprogram. However, the following case
560 -- falls outside the scope of that AI. Randy Brukardt explained on the
561 -- ARG list on 2013/02/07 that:
564 -- But for an operation like "<" [the ordered set analog of
565 -- Equivalent_Elements], there is no need to "dereference" a cursor
566 -- after the call to the generic formal parameter function, so nothing
567 -- bad could happen if tampering is undetected. And the operation can
568 -- safely return a result without a problem even if an element is
569 -- deleted from the container.
572 return Equivalent_Elements
573 (Left.Node.Element.all,
574 Right.Node.Element.all);
575 end Equivalent_Elements;
577 function Equivalent_Elements
579 Right : Element_Type) return Boolean
582 if Left.Node = null then
583 raise Constraint_Error with
584 "Left cursor of Equivalent_Elements equals No_Element";
587 if Left.Node.Element = null then
588 raise Program_Error with
589 "Left cursor of Equivalent_Elements is bad";
592 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
594 return Equivalent_Elements (Left.Node.Element.all, Right);
595 end Equivalent_Elements;
597 function Equivalent_Elements
598 (Left : Element_Type;
599 Right : Cursor) return Boolean
602 if Right.Node = null then
603 raise Constraint_Error with
604 "Right cursor of Equivalent_Elements equals No_Element";
607 if Right.Node.Element = null then
608 raise Program_Error with
609 "Right cursor of Equivalent_Elements is bad";
612 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
614 return Equivalent_Elements (Left, Right.Node.Element.all);
615 end Equivalent_Elements;
617 ---------------------
618 -- Equivalent_Keys --
619 ---------------------
621 function Equivalent_Keys
623 Node : Node_Access) return Boolean
626 return Equivalent_Elements (Key, Node.Element.all);
634 (Container : in out Set;
639 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
647 procedure Finalize (Container : in out Set) is
649 HT_Ops.Finalize (Container.HT);
652 procedure Finalize (Object : in out Iterator) is
654 if Object.Container /= null then
656 B : Natural renames Object.Container.all.HT.Busy;
663 procedure Finalize (Control : in out Reference_Control_Type) is
665 if Control.Container /= null then
667 HT : Hash_Table_Type renames Control.Container.all.HT;
668 B : Natural renames HT.Busy;
669 L : Natural renames HT.Lock;
675 Control.Container := null;
685 Item : Element_Type) return Cursor
687 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
688 Node : constant Node_Access := Element_Keys.Find (HT, Item);
690 return (if Node = null then No_Element
691 else Cursor'(Container'Unrestricted_Access, Node));
698 function Find_Equal_Key
699 (R_HT : Hash_Table_Type;
700 L_Node : Node_Access) return Boolean
702 R_Index : constant Hash_Type :=
703 Element_Keys.Index (R_HT, L_Node.Element.all);
705 R_Node : Node_Access := R_HT.Buckets (R_Index);
709 if R_Node = null then
713 if L_Node.Element.all = R_Node.Element.all then
717 R_Node := Next (R_Node);
721 -------------------------
722 -- Find_Equivalent_Key --
723 -------------------------
725 function Find_Equivalent_Key
726 (R_HT : Hash_Table_Type;
727 L_Node : Node_Access) return Boolean
729 R_Index : constant Hash_Type :=
730 Element_Keys.Index (R_HT, L_Node.Element.all);
732 R_Node : Node_Access := R_HT.Buckets (R_Index);
736 if R_Node = null then
740 if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
744 R_Node := Next (R_Node);
746 end Find_Equivalent_Key;
752 function First (Container : Set) return Cursor is
753 Node : constant Node_Access := HT_Ops.First (Container.HT);
755 return (if Node = null then No_Element
756 else Cursor'(Container'Unrestricted_Access, Node));
759 function First (Object : Iterator) return Cursor is
761 return Object.Container.First;
768 procedure Free (X : in out Node_Access) is
769 procedure Deallocate is
770 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
777 X.Next := X; -- detect mischief (in Vet)
780 Free_Element (X.Element);
796 function Has_Element (Position : Cursor) return Boolean is
798 pragma Assert (Vet (Position), "bad cursor in Has_Element");
799 return Position.Node /= null;
806 function Hash_Node (Node : Node_Access) return Hash_Type is
808 return Hash (Node.Element.all);
816 (Container : in out Set;
817 New_Item : Element_Type)
825 Insert (Container, New_Item, Position, Inserted);
828 if Container.HT.Lock > 0 then
829 raise Program_Error with
830 "attempt to tamper with elements (set is locked)";
833 X := Position.Node.Element;
836 -- The element allocator may need an accessibility check in the
837 -- case the actual type is class-wide or has access discriminants
838 -- (see RM 4.8(10.1) and AI12-0035).
840 pragma Unsuppress (Accessibility_Check);
843 Position.Node.Element := new Element_Type'(New_Item);
855 (Container : in out Set;
856 New_Item : Element_Type;
857 Position : out Cursor;
858 Inserted : out Boolean)
861 Insert (Container.HT, New_Item, Position.Node, Inserted);
862 Position.Container := Container'Unchecked_Access;
866 (Container : in out Set;
867 New_Item : Element_Type)
870 pragma Unreferenced (Position);
875 Insert (Container, New_Item, Position, Inserted);
878 raise Constraint_Error with
879 "attempt to insert element already in set";
884 (HT : in out Hash_Table_Type;
885 New_Item : Element_Type;
886 Node : out Node_Access;
887 Inserted : out Boolean)
889 function New_Node (Next : Node_Access) return Node_Access;
890 pragma Inline (New_Node);
892 procedure Local_Insert is
893 new Element_Keys.Generic_Conditional_Insert (New_Node);
899 function New_Node (Next : Node_Access) return Node_Access is
901 -- The element allocator may need an accessibility check in the case
902 -- the actual type is class-wide or has access discriminants (see
903 -- RM 4.8(10.1) and AI12-0035).
905 pragma Unsuppress (Accessibility_Check);
907 Element : Element_Access := new Element_Type'(New_Item);
910 return new Node_Type'(Element, Next);
914 Free_Element (Element);
918 -- Start of processing for Insert
921 if HT_Ops.Capacity (HT) = 0 then
922 HT_Ops.Reserve_Capacity (HT, 1);
925 Local_Insert (HT, New_Item, Node, Inserted);
927 if Inserted and then HT.Length > HT_Ops.Capacity (HT) then
928 HT_Ops.Reserve_Capacity (HT, HT.Length);
936 procedure Intersection
937 (Target : in out Set;
940 Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT;
941 Tgt_Node : Node_Access;
944 if Target'Address = Source'Address then
948 if Source.Length = 0 then
953 if Target.HT.Busy > 0 then
954 raise Program_Error with
955 "attempt to tamper with cursors (set is busy)";
958 Tgt_Node := HT_Ops.First (Target.HT);
959 while Tgt_Node /= null loop
960 if Is_In (Src_HT, Tgt_Node) then
961 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
965 X : Node_Access := Tgt_Node;
967 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
968 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
975 function Intersection (Left, Right : Set) return Set is
976 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
977 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
978 Buckets : HT_Types.Buckets_Access;
982 if Left'Address = Right'Address then
986 Length := Count_Type'Min (Left.Length, Right.Length);
993 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
995 Buckets := HT_Ops.New_Buckets (Length => Size);
1000 Iterate_Left : declare
1001 procedure Process (L_Node : Node_Access);
1003 procedure Iterate is
1004 new HT_Ops.Generic_Iteration (Process);
1010 procedure Process (L_Node : Node_Access) is
1012 if Is_In (Right_HT, L_Node) then
1014 -- Per AI05-0022, the container implementation is required
1015 -- to detect element tampering by a generic actual
1016 -- subprogram, hence the use of Checked_Index instead of a
1017 -- simple invocation of generic formal Hash.
1019 Indx : constant Hash_Type :=
1020 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
1022 Bucket : Node_Access renames Buckets (Indx);
1024 Src : Element_Type renames L_Node.Element.all;
1025 Tgt : Element_Access := new Element_Type'(Src);
1028 Bucket := new Node_Type'(Tgt, Bucket);
1036 Length := Length + 1;
1040 -- Start of processing for Iterate_Left
1047 HT_Ops.Free_Hash_Table (Buckets);
1051 return (Controlled with HT => (Buckets, Length, 0, 0));
1058 function Is_Empty (Container : Set) return Boolean is
1060 return Container.HT.Length = 0;
1068 (HT : aliased in out Hash_Table_Type;
1069 Key : Node_Access) return Boolean
1072 return Element_Keys.Find (HT, Key.Element.all) /= null;
1081 Of_Set : Set) return Boolean
1083 Subset_HT : Hash_Table_Type renames Subset'Unrestricted_Access.HT;
1084 Of_Set_HT : Hash_Table_Type renames Of_Set'Unrestricted_Access.HT;
1085 Subset_Node : Node_Access;
1088 if Subset'Address = Of_Set'Address then
1092 if Subset.Length > Of_Set.Length then
1096 Subset_Node := HT_Ops.First (Subset_HT);
1097 while Subset_Node /= null loop
1098 if not Is_In (Of_Set_HT, Subset_Node) then
1102 Subset_Node := HT_Ops.Next (Subset_HT, Subset_Node);
1114 Process : not null access procedure (Position : Cursor))
1116 procedure Process_Node (Node : Node_Access);
1117 pragma Inline (Process_Node);
1119 procedure Iterate is
1120 new HT_Ops.Generic_Iteration (Process_Node);
1126 procedure Process_Node (Node : Node_Access) is
1128 Process (Cursor'(Container'Unrestricted_Access, Node));
1131 B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1133 -- Start of processing for Iterate
1139 Iterate (Container.HT);
1149 function Iterate (Container : Set)
1150 return Set_Iterator_Interfaces.Forward_Iterator'Class
1152 B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1154 return It : constant Iterator :=
1155 Iterator'(Limited_Controlled with
1156 Container => Container'Unrestricted_Access)
1166 function Length (Container : Set) return Count_Type is
1168 return Container.HT.Length;
1175 procedure Move (Target : in out Set; Source : in out Set) is
1177 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
1184 function Next (Node : Node_Access) return Node_Access is
1189 function Next (Position : Cursor) return Cursor is
1191 if Position.Node = null then
1195 if Position.Node.Element = null then
1196 raise Program_Error with "bad cursor in Next";
1199 pragma Assert (Vet (Position), "bad cursor in Next");
1202 HT : Hash_Table_Type renames Position.Container.HT;
1203 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
1205 return (if Node = null then No_Element
1206 else Cursor'(Position.Container, Node));
1210 procedure Next (Position : in out Cursor) is
1212 Position := Next (Position);
1217 Position : Cursor) return Cursor
1220 if Position.Container = null then
1224 if Position.Container /= Object.Container then
1225 raise Program_Error with
1226 "Position cursor of Next designates wrong set";
1229 return Next (Position);
1236 function Overlap (Left, Right : Set) return Boolean is
1237 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
1238 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
1239 Left_Node : Node_Access;
1242 if Right.Length = 0 then
1246 if Left'Address = Right'Address then
1250 Left_Node := HT_Ops.First (Left_HT);
1251 while Left_Node /= null loop
1252 if Is_In (Right_HT, Left_Node) then
1256 Left_Node := HT_Ops.Next (Left_HT, Left_Node);
1266 procedure Query_Element
1268 Process : not null access procedure (Element : Element_Type))
1271 if Position.Node = null then
1272 raise Constraint_Error with
1273 "Position cursor of Query_Element equals No_Element";
1276 if Position.Node.Element = null then
1277 raise Program_Error with "bad cursor in Query_Element";
1280 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1283 HT : Hash_Table_Type renames
1284 Position.Container'Unrestricted_Access.all.HT;
1286 B : Natural renames HT.Busy;
1287 L : Natural renames HT.Lock;
1294 Process (Position.Node.Element.all);
1312 (Stream : not null access Root_Stream_Type'Class;
1313 Container : out Set)
1316 Read_Nodes (Stream, Container.HT);
1320 (Stream : not null access Root_Stream_Type'Class;
1324 raise Program_Error with "attempt to stream set cursor";
1328 (Stream : not null access Root_Stream_Type'Class;
1329 Item : out Constant_Reference_Type)
1332 raise Program_Error with "attempt to stream reference";
1340 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1342 X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
1344 return new Node_Type'(X, null);
1356 (Container : in out Set;
1357 New_Item : Element_Type)
1359 Node : constant Node_Access :=
1360 Element_Keys.Find (Container.HT, New_Item);
1363 pragma Warnings (Off, X);
1367 raise Constraint_Error with
1368 "attempt to replace element not in set";
1371 if Container.HT.Lock > 0 then
1372 raise Program_Error with
1373 "attempt to tamper with elements (set is locked)";
1379 -- The element allocator may need an accessibility check in the case
1380 -- the actual type is class-wide or has access discriminants (see
1381 -- RM 4.8(10.1) and AI12-0035).
1383 pragma Unsuppress (Accessibility_Check);
1386 Node.Element := new Element_Type'(New_Item);
1392 ---------------------
1393 -- Replace_Element --
1394 ---------------------
1396 procedure Replace_Element
1397 (Container : in out Set;
1399 New_Item : Element_Type)
1402 if Position.Node = null then
1403 raise Constraint_Error with "Position cursor equals No_Element";
1406 if Position.Node.Element = null then
1407 raise Program_Error with "bad cursor in Replace_Element";
1410 if Position.Container /= Container'Unrestricted_Access then
1411 raise Program_Error with
1412 "Position cursor designates wrong set";
1415 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1417 Replace_Element (Container.HT, Position.Node, New_Item);
1418 end Replace_Element;
1420 ----------------------
1421 -- Reserve_Capacity --
1422 ----------------------
1424 procedure Reserve_Capacity
1425 (Container : in out Set;
1426 Capacity : Count_Type)
1429 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1430 end Reserve_Capacity;
1436 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1441 --------------------------
1442 -- Symmetric_Difference --
1443 --------------------------
1445 procedure Symmetric_Difference
1446 (Target : in out Set;
1449 Tgt_HT : Hash_Table_Type renames Target.HT;
1450 Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all;
1452 -- Per AI05-0022, the container implementation is required to detect
1453 -- element tampering by a generic actual subprogram.
1455 TB : Natural renames Tgt_HT.Busy;
1456 TL : Natural renames Tgt_HT.Lock;
1458 SB : Natural renames Src_HT.Busy;
1459 SL : Natural renames Src_HT.Lock;
1462 if Target'Address = Source'Address then
1468 raise Program_Error with
1469 "attempt to tamper with cursors (set is busy)";
1473 N : constant Count_Type := Target.Length + Source.Length;
1475 if N > HT_Ops.Capacity (Tgt_HT) then
1476 HT_Ops.Reserve_Capacity (Tgt_HT, N);
1480 if Target.Length = 0 then
1481 Iterate_Source_When_Empty_Target : declare
1482 procedure Process (Src_Node : Node_Access);
1484 procedure Iterate is new HT_Ops.Generic_Iteration (Process);
1490 procedure Process (Src_Node : Node_Access) is
1491 E : Element_Type renames Src_Node.Element.all;
1492 B : Buckets_Type renames Tgt_HT.Buckets.all;
1493 J : constant Hash_Type := Hash (E) mod B'Length;
1494 N : Count_Type renames Tgt_HT.Length;
1498 X : Element_Access := new Element_Type'(E);
1500 B (J) := new Node_Type'(X, B (J));
1510 -- Start of processing for Iterate_Source_When_Empty_Target
1536 end Iterate_Source_When_Empty_Target;
1539 Iterate_Source : declare
1540 procedure Process (Src_Node : Node_Access);
1542 procedure Iterate is
1543 new HT_Ops.Generic_Iteration (Process);
1549 procedure Process (Src_Node : Node_Access) is
1550 E : Element_Type renames Src_Node.Element.all;
1551 B : Buckets_Type renames Tgt_HT.Buckets.all;
1552 J : constant Hash_Type := Hash (E) mod B'Length;
1553 N : Count_Type renames Tgt_HT.Length;
1556 if B (J) = null then
1558 X : Element_Access := new Element_Type'(E);
1560 B (J) := new Node_Type'(X, null);
1569 elsif Equivalent_Elements (E, B (J).Element.all) then
1571 X : Node_Access := B (J);
1573 B (J) := B (J).Next;
1580 Prev : Node_Access := B (J);
1581 Curr : Node_Access := Prev.Next;
1584 while Curr /= null loop
1585 if Equivalent_Elements (E, Curr.Element.all) then
1586 Prev.Next := Curr.Next;
1597 X : Element_Access := new Element_Type'(E);
1599 B (J) := new Node_Type'(X, B (J));
1611 -- Start of processing for Iterate_Source
1639 end Symmetric_Difference;
1641 function Symmetric_Difference (Left, Right : Set) return Set is
1642 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
1643 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
1644 Buckets : HT_Types.Buckets_Access;
1645 Length : Count_Type;
1648 if Left'Address = Right'Address then
1652 if Right.Length = 0 then
1656 if Left.Length = 0 then
1661 Size : constant Hash_Type :=
1662 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1664 Buckets := HT_Ops.New_Buckets (Length => Size);
1669 Iterate_Left : declare
1670 procedure Process (L_Node : Node_Access);
1672 procedure Iterate is
1673 new HT_Ops.Generic_Iteration (Process);
1679 procedure Process (L_Node : Node_Access) is
1681 if not Is_In (Right_HT, L_Node) then
1683 E : Element_Type renames L_Node.Element.all;
1685 -- Per AI05-0022, the container implementation is required
1686 -- to detect element tampering by a generic actual
1687 -- subprogram, hence the use of Checked_Index instead of a
1688 -- simple invocation of generic formal Hash.
1690 J : constant Hash_Type :=
1691 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
1695 X : Element_Access := new Element_Type'(E);
1697 Buckets (J) := new Node_Type'(X, Buckets (J));
1704 Length := Length + 1;
1709 -- Start of processing for Iterate_Left
1715 HT_Ops.Free_Hash_Table (Buckets);
1719 Iterate_Right : declare
1720 procedure Process (R_Node : Node_Access);
1722 procedure Iterate is
1723 new HT_Ops.Generic_Iteration (Process);
1729 procedure Process (R_Node : Node_Access) is
1731 if not Is_In (Left_HT, R_Node) then
1733 E : Element_Type renames R_Node.Element.all;
1735 -- Per AI05-0022, the container implementation is required
1736 -- to detect element tampering by a generic actual
1737 -- subprogram, hence the use of Checked_Index instead of a
1738 -- simple invocation of generic formal Hash.
1740 J : constant Hash_Type :=
1741 HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node);
1745 X : Element_Access := new Element_Type'(E);
1747 Buckets (J) := new Node_Type'(X, Buckets (J));
1754 Length := Length + 1;
1759 -- Start of processing for Iterate_Right
1766 HT_Ops.Free_Hash_Table (Buckets);
1770 return (Controlled with HT => (Buckets, Length, 0, 0));
1771 end Symmetric_Difference;
1777 function To_Set (New_Item : Element_Type) return Set is
1778 HT : Hash_Table_Type;
1781 pragma Unreferenced (Node, Inserted);
1783 Insert (HT, New_Item, Node, Inserted);
1784 return Set'(Controlled with HT);
1792 (Target : in out Set;
1795 procedure Process (Src_Node : Node_Access);
1797 procedure Iterate is
1798 new HT_Ops.Generic_Iteration (Process);
1804 procedure Process (Src_Node : Node_Access) is
1805 Src : Element_Type renames Src_Node.Element.all;
1807 function New_Node (Next : Node_Access) return Node_Access;
1808 pragma Inline (New_Node);
1811 new Element_Keys.Generic_Conditional_Insert (New_Node);
1817 function New_Node (Next : Node_Access) return Node_Access is
1818 Tgt : Element_Access := new Element_Type'(Src);
1820 return new Node_Type'(Tgt, Next);
1827 Tgt_Node : Node_Access;
1829 pragma Unreferenced (Tgt_Node, Success);
1831 -- Start of processing for Process
1834 Insert (Target.HT, Src, Tgt_Node, Success);
1837 -- Start of processing for Union
1840 if Target'Address = Source'Address then
1844 if Target.HT.Busy > 0 then
1845 raise Program_Error with
1846 "attempt to tamper with cursors (set is busy)";
1850 N : constant Count_Type := Target.Length + Source.Length;
1852 if N > HT_Ops.Capacity (Target.HT) then
1853 HT_Ops.Reserve_Capacity (Target.HT, N);
1857 Iterate (Source.HT);
1860 function Union (Left, Right : Set) return Set is
1861 Left_HT : Hash_Table_Type renames Left.HT'Unrestricted_Access.all;
1862 Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all;
1863 Buckets : HT_Types.Buckets_Access;
1864 Length : Count_Type;
1867 if Left'Address = Right'Address then
1871 if Right.Length = 0 then
1875 if Left.Length = 0 then
1880 Size : constant Hash_Type :=
1881 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1883 Buckets := HT_Ops.New_Buckets (Length => Size);
1886 Iterate_Left : declare
1887 procedure Process (L_Node : Node_Access);
1889 procedure Iterate is
1890 new HT_Ops.Generic_Iteration (Process);
1896 procedure Process (L_Node : Node_Access) is
1897 Src : Element_Type renames L_Node.Element.all;
1898 J : constant Hash_Type := Hash (Src) mod Buckets'Length;
1899 Bucket : Node_Access renames Buckets (J);
1900 Tgt : Element_Access := new Element_Type'(Src);
1902 Bucket := new Node_Type'(Tgt, Bucket);
1909 -- Per AI05-0022, the container implementation is required to detect
1910 -- element tampering by a generic actual subprogram, hence the use of
1911 -- Checked_Index instead of a simple invocation of generic formal
1914 B : Integer renames Left_HT.Busy;
1915 L : Integer renames Left_HT.Lock;
1917 -- Start of processing for Iterate_Left
1933 HT_Ops.Free_Hash_Table (Buckets);
1937 Length := Left.Length;
1939 Iterate_Right : declare
1940 procedure Process (Src_Node : Node_Access);
1942 procedure Iterate is
1943 new HT_Ops.Generic_Iteration (Process);
1949 procedure Process (Src_Node : Node_Access) is
1950 Src : Element_Type renames Src_Node.Element.all;
1951 Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
1953 Tgt_Node : Node_Access := Buckets (Idx);
1956 while Tgt_Node /= null loop
1957 if Equivalent_Elements (Src, Tgt_Node.Element.all) then
1960 Tgt_Node := Next (Tgt_Node);
1964 Tgt : Element_Access := new Element_Type'(Src);
1966 Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx));
1973 Length := Length + 1;
1976 -- Per AI05-0022, the container implementation is required to detect
1977 -- element tampering by a generic actual subprogram, hence the use of
1978 -- Checked_Index instead of a simple invocation of generic formal
1981 LB : Integer renames Left_HT.Busy;
1982 LL : Integer renames Left_HT.Lock;
1984 RB : Integer renames Right_HT.Busy;
1985 RL : Integer renames Right_HT.Lock;
1987 -- Start of processing for Iterate_Right
2012 HT_Ops.Free_Hash_Table (Buckets);
2016 return (Controlled with HT => (Buckets, Length, 0, 0));
2023 function Vet (Position : Cursor) return Boolean is
2025 if Position.Node = null then
2026 return Position.Container = null;
2029 if Position.Container = null then
2033 if Position.Node.Next = Position.Node then
2037 if Position.Node.Element = null then
2042 HT : Hash_Table_Type renames Position.Container.HT;
2046 if HT.Length = 0 then
2050 if HT.Buckets = null
2051 or else HT.Buckets'Length = 0
2056 X := HT.Buckets (Element_Keys.Checked_Index
2058 Position.Node.Element.all));
2060 for J in 1 .. HT.Length loop
2061 if X = Position.Node then
2069 if X = X.Next then -- to prevent unnecessary looping
2085 (Stream : not null access Root_Stream_Type'Class;
2089 Write_Nodes (Stream, Container.HT);
2093 (Stream : not null access Root_Stream_Type'Class;
2097 raise Program_Error with "attempt to stream set cursor";
2101 (Stream : not null access Root_Stream_Type'Class;
2102 Item : Constant_Reference_Type)
2105 raise Program_Error with "attempt to stream reference";
2112 procedure Write_Node
2113 (Stream : not null access Root_Stream_Type'Class;
2117 Element_Type'Output (Stream, Node.Element.all);
2120 package body Generic_Keys is
2122 -----------------------
2123 -- Local Subprograms --
2124 -----------------------
2126 function Equivalent_Key_Node
2128 Node : Node_Access) return Boolean;
2129 pragma Inline (Equivalent_Key_Node);
2131 --------------------------
2132 -- Local Instantiations --
2133 --------------------------
2136 new Hash_Tables.Generic_Keys
2137 (HT_Types => HT_Types,
2139 Set_Next => Set_Next,
2140 Key_Type => Key_Type,
2142 Equivalent_Keys => Equivalent_Key_Node);
2148 procedure Adjust (Control : in out Reference_Control_Type) is
2150 if Control.Container /= null then
2152 HT : Hash_Table_Type renames Control.Container.HT;
2153 B : Natural renames HT.Busy;
2154 L : Natural renames HT.Lock;
2162 ------------------------
2163 -- Constant_Reference --
2164 ------------------------
2166 function Constant_Reference
2167 (Container : aliased Set;
2168 Key : Key_Type) return Constant_Reference_Type
2170 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
2171 Node : constant Node_Access := Key_Keys.Find (HT, Key);
2175 raise Constraint_Error with "Key not in set";
2178 if Node.Element = null then
2179 raise Program_Error with "Node has no element";
2183 B : Natural renames HT.Busy;
2184 L : Natural renames HT.Lock;
2186 return R : constant Constant_Reference_Type :=
2187 (Element => Node.Element.all'Access,
2188 Control => (Controlled with Container'Unrestricted_Access))
2194 end Constant_Reference;
2202 Key : Key_Type) return Boolean
2205 return Find (Container, Key) /= No_Element;
2213 (Container : in out Set;
2219 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2222 raise Constraint_Error with "key not in set";
2234 Key : Key_Type) return Element_Type
2236 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
2237 Node : constant Node_Access := Key_Keys.Find (HT, Key);
2241 raise Constraint_Error with "key not in set";
2244 return Node.Element.all;
2247 -------------------------
2248 -- Equivalent_Key_Node --
2249 -------------------------
2251 function Equivalent_Key_Node
2253 Node : Node_Access) return Boolean is
2255 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
2256 end Equivalent_Key_Node;
2263 (Container : in out Set;
2268 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2276 procedure Finalize (Control : in out Reference_Control_Type) is
2278 if Control.Container /= null then
2280 HT : Hash_Table_Type renames Control.Container.HT;
2281 B : Natural renames HT.Busy;
2282 L : Natural renames HT.Lock;
2288 if Hash (Key (Control.Old_Pos)) /= Control.Old_Hash then
2289 HT_Ops.Delete_Node_At_Index
2290 (Control.Container.HT, Control.Index, Control.Old_Pos.Node);
2291 raise Program_Error;
2294 Control.Container := null;
2304 Key : Key_Type) return Cursor
2306 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
2307 Node : constant Node_Access := Key_Keys.Find (HT, Key);
2309 return (if Node = null then No_Element
2310 else Cursor'(Container'Unrestricted_Access, Node));
2317 function Key (Position : Cursor) return Key_Type is
2319 if Position.Node = null then
2320 raise Constraint_Error with
2321 "Position cursor equals No_Element";
2324 if Position.Node.Element = null then
2325 raise Program_Error with "Position cursor is bad";
2328 pragma Assert (Vet (Position), "bad cursor in function Key");
2330 return Key (Position.Node.Element.all);
2338 (Stream : not null access Root_Stream_Type'Class;
2339 Item : out Reference_Type)
2342 raise Program_Error with "attempt to stream reference";
2345 ------------------------------
2346 -- Reference_Preserving_Key --
2347 ------------------------------
2349 function Reference_Preserving_Key
2350 (Container : aliased in out Set;
2351 Position : Cursor) return Reference_Type
2354 if Position.Container = null then
2355 raise Constraint_Error with "Position cursor has no element";
2358 if Position.Container /= Container'Unrestricted_Access then
2359 raise Program_Error with
2360 "Position cursor designates wrong container";
2363 if Position.Node.Element = null then
2364 raise Program_Error with "Node has no element";
2369 "bad cursor in function Reference_Preserving_Key");
2372 HT : Hash_Table_Type renames Container.HT;
2373 B : Natural renames HT.Busy;
2374 L : Natural renames HT.Lock;
2376 return R : constant Reference_Type :=
2377 (Element => Position.Node.Element.all'Access,
2380 Container => Container'Access,
2381 Index => HT_Ops.Index (HT, Position.Node),
2382 Old_Pos => Position,
2383 Old_Hash => Hash (Key (Position))))
2389 end Reference_Preserving_Key;
2391 function Reference_Preserving_Key
2392 (Container : aliased in out Set;
2393 Key : Key_Type) return Reference_Type
2395 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2399 raise Constraint_Error with "Key not in set";
2402 if Node.Element = null then
2403 raise Program_Error with "Node has no element";
2407 HT : Hash_Table_Type renames Container.HT;
2408 B : Natural renames HT.Busy;
2409 L : Natural renames HT.Lock;
2410 P : constant Cursor := Find (Container, Key);
2412 return R : constant Reference_Type :=
2413 (Element => Node.Element.all'Access,
2416 Container => Container'Access,
2417 Index => HT_Ops.Index (HT, P.Node),
2419 Old_Hash => Hash (Key)))
2425 end Reference_Preserving_Key;
2432 (Container : in out Set;
2434 New_Item : Element_Type)
2436 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2440 raise Constraint_Error with
2441 "attempt to replace key not in set";
2444 Replace_Element (Container.HT, Node, New_Item);
2447 -----------------------------------
2448 -- Update_Element_Preserving_Key --
2449 -----------------------------------
2451 procedure Update_Element_Preserving_Key
2452 (Container : in out Set;
2454 Process : not null access
2455 procedure (Element : in out Element_Type))
2457 HT : Hash_Table_Type renames Container.HT;
2461 if Position.Node = null then
2462 raise Constraint_Error with
2463 "Position cursor equals No_Element";
2466 if Position.Node.Element = null
2467 or else Position.Node.Next = Position.Node
2469 raise Program_Error with "Position cursor is bad";
2472 if Position.Container /= Container'Unrestricted_Access then
2473 raise Program_Error with
2474 "Position cursor designates wrong set";
2477 if HT.Buckets = null
2478 or else HT.Buckets'Length = 0
2479 or else HT.Length = 0
2481 raise Program_Error with "Position cursor is bad (set is empty)";
2486 "bad cursor in Update_Element_Preserving_Key");
2488 -- Per AI05-0022, the container implementation is required to detect
2489 -- element tampering by a generic actual subprogram.
2492 E : Element_Type renames Position.Node.Element.all;
2493 K : constant Key_Type := Key (E);
2495 B : Natural renames HT.Busy;
2496 L : Natural renames HT.Lock;
2505 Indx := HT_Ops.Index (HT, Position.Node);
2507 Eq := Equivalent_Keys (K, Key (E));
2525 if HT.Buckets (Indx) = Position.Node then
2526 HT.Buckets (Indx) := Position.Node.Next;
2530 Prev : Node_Access := HT.Buckets (Indx);
2533 while Prev.Next /= Position.Node loop
2537 raise Program_Error with
2538 "Position cursor is bad (node not found)";
2542 Prev.Next := Position.Node.Next;
2546 HT.Length := HT.Length - 1;
2549 X : Node_Access := Position.Node;
2555 raise Program_Error with "key was modified";
2556 end Update_Element_Preserving_Key;
2563 (Stream : not null access Root_Stream_Type'Class;
2564 Item : Reference_Type)
2567 raise Program_Error with "attempt to stream reference";
2572 end Ada.Containers.Indefinite_Hashed_Sets;