1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ S E T S --
9 -- Copyright (C) 2004-2011, 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.Containers.Hash_Tables.Generic_Bounded_Operations;
31 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
33 with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
34 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
36 with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
38 with System; use type System.Address;
40 package body Ada.Containers.Bounded_Hashed_Sets is
42 type Iterator is new Set_Iterator_Interfaces.Forward_Iterator with record
43 Container : Set_Access;
47 overriding function First (Object : Iterator) return Cursor;
49 overriding function Next
51 Position : Cursor) return Cursor;
53 -----------------------
54 -- Local Subprograms --
55 -----------------------
57 function Equivalent_Keys
59 Node : Node_Type) return Boolean;
60 pragma Inline (Equivalent_Keys);
62 function Hash_Node (Node : Node_Type) return Hash_Type;
63 pragma Inline (Hash_Node);
66 (Container : in out Set;
67 New_Item : Element_Type;
68 Node : out Count_Type;
69 Inserted : out Boolean);
71 function Is_In (HT : Set; Key : Node_Type) return Boolean;
72 pragma Inline (Is_In);
74 procedure Set_Element (Node : in out Node_Type; Item : Element_Type);
75 pragma Inline (Set_Element);
77 function Next (Node : Node_Type) return Count_Type;
80 procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
81 pragma Inline (Set_Next);
83 function Vet (Position : Cursor) return Boolean;
85 --------------------------
86 -- Local Instantiations --
87 --------------------------
89 package HT_Ops is new Hash_Tables.Generic_Bounded_Operations
90 (HT_Types => HT_Types,
91 Hash_Node => Hash_Node,
93 Set_Next => Set_Next);
95 package Element_Keys is new Hash_Tables.Generic_Bounded_Keys
96 (HT_Types => HT_Types,
99 Key_Type => Element_Type,
101 Equivalent_Keys => Equivalent_Keys);
103 procedure Replace_Element is
104 new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element);
110 function "=" (Left, Right : Set) return Boolean is
111 function Find_Equal_Key
112 (R_HT : Hash_Table_Type'Class;
113 L_Node : Node_Type) return Boolean;
114 pragma Inline (Find_Equal_Key);
117 new HT_Ops.Generic_Equal (Find_Equal_Key);
123 function Find_Equal_Key
124 (R_HT : Hash_Table_Type'Class;
125 L_Node : Node_Type) return Boolean
127 R_Index : constant Hash_Type :=
128 Element_Keys.Index (R_HT, L_Node.Element);
130 R_Node : Count_Type := R_HT.Buckets (R_Index);
138 if L_Node.Element = R_HT.Nodes (R_Node).Element then
142 R_Node := Next (R_HT.Nodes (R_Node));
146 -- Start of processing for "="
149 return Is_Equal (Left, Right);
156 procedure Assign (Target : in out Set; Source : Set) is
157 procedure Insert_Element (Source_Node : Count_Type);
159 procedure Insert_Elements is
160 new HT_Ops.Generic_Iteration (Insert_Element);
166 procedure Insert_Element (Source_Node : Count_Type) is
167 N : Node_Type renames Source.Nodes (Source_Node);
171 Insert (Target, N.Element, X, B);
175 -- Start of processing for Assign
178 if Target'Address = Source'Address then
182 if Target.Capacity < Source.Length then
184 with "Target capacity is less than Source length";
187 HT_Ops.Clear (Target);
188 Insert_Elements (Source);
195 function Capacity (Container : Set) return Count_Type is
197 return Container.Capacity;
204 procedure Clear (Container : in out Set) is
206 HT_Ops.Clear (Container);
213 function Contains (Container : Set; Item : Element_Type) return Boolean is
215 return Find (Container, Item) /= No_Element;
224 Capacity : Count_Type := 0;
225 Modulus : Hash_Type := 0) return Set
233 elsif Capacity >= Source.Length then
236 raise Capacity_Error with "Capacity value too small";
240 M := Default_Modulus (C);
245 return Target : Set (Capacity => C, Modulus => M) do
246 Assign (Target => Target, Source => Source);
250 ---------------------
251 -- Default_Modulus --
252 ---------------------
254 function Default_Modulus (Capacity : Count_Type) return Hash_Type is
256 return To_Prime (Capacity);
264 (Container : in out Set;
270 Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
273 raise Constraint_Error with "attempt to delete element not in set";
276 HT_Ops.Free (Container, X);
280 (Container : in out Set;
281 Position : in out Cursor)
284 if Position.Node = 0 then
285 raise Constraint_Error with "Position cursor equals No_Element";
288 if Position.Container /= Container'Unrestricted_Access then
289 raise Program_Error with "Position cursor designates wrong set";
292 if Container.Busy > 0 then
293 raise Program_Error with
294 "attempt to tamper with cursors (set is busy)";
297 pragma Assert (Vet (Position), "bad cursor in Delete");
299 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
300 HT_Ops.Free (Container, Position.Node);
302 Position := No_Element;
310 (Target : in out Set;
313 Tgt_Node, Src_Node : Count_Type;
315 TN : Nodes_Type renames Target.Nodes;
316 SN : Nodes_Type renames Source.Nodes;
319 if Target'Address = Source'Address then
320 HT_Ops.Clear (Target);
324 if Source.Length = 0 then
328 if Target.Busy > 0 then
329 raise Program_Error with
330 "attempt to tamper with cursors (set is busy)";
333 if Source.Length < Target.Length then
334 Src_Node := HT_Ops.First (Source);
335 while Src_Node /= 0 loop
336 Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element);
338 if Tgt_Node /= 0 then
339 HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node);
340 HT_Ops.Free (Target, Tgt_Node);
343 Src_Node := HT_Ops.Next (Source, Src_Node);
347 Tgt_Node := HT_Ops.First (Target);
348 while Tgt_Node /= 0 loop
349 if Is_In (Source, TN (Tgt_Node)) then
351 X : constant Count_Type := Tgt_Node;
353 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
354 HT_Ops.Delete_Node_Sans_Free (Target, X);
355 HT_Ops.Free (Target, X);
359 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
365 function Difference (Left, Right : Set) return Set is
367 if Left'Address = Right'Address then
371 if Left.Length = 0 then
375 if Right.Length = 0 then
379 return Result : Set (Left.Length, To_Prime (Left.Length)) do
380 Iterate_Left : declare
381 procedure Process (L_Node : Count_Type);
384 new HT_Ops.Generic_Iteration (Process);
390 procedure Process (L_Node : Count_Type) is
391 N : Node_Type renames Left.Nodes (L_Node);
395 if not Is_In (Right, N) then
396 Insert (Result, N.Element, X, B); -- optimize this ???
398 pragma Assert (X > 0);
402 -- Start of processing for Iterate_Left
414 function Element (Position : Cursor) return Element_Type is
416 if Position.Node = 0 then
417 raise Constraint_Error with "Position cursor equals No_Element";
420 pragma Assert (Vet (Position), "bad cursor in function Element");
423 S : Set renames Position.Container.all;
424 N : Node_Type renames S.Nodes (Position.Node);
430 ---------------------
431 -- Equivalent_Sets --
432 ---------------------
434 function Equivalent_Sets (Left, Right : Set) return Boolean is
435 function Find_Equivalent_Key
436 (R_HT : Hash_Table_Type'Class;
437 L_Node : Node_Type) return Boolean;
438 pragma Inline (Find_Equivalent_Key);
440 function Is_Equivalent is
441 new HT_Ops.Generic_Equal (Find_Equivalent_Key);
443 -------------------------
444 -- Find_Equivalent_Key --
445 -------------------------
447 function Find_Equivalent_Key
448 (R_HT : Hash_Table_Type'Class;
449 L_Node : Node_Type) return Boolean
451 R_Index : constant Hash_Type :=
452 Element_Keys.Index (R_HT, L_Node.Element);
454 R_Node : Count_Type := R_HT.Buckets (R_Index);
456 RN : Nodes_Type renames R_HT.Nodes;
464 if Equivalent_Elements (L_Node.Element, RN (R_Node).Element) then
468 R_Node := HT_Ops.Next (R_HT, R_Node);
470 end Find_Equivalent_Key;
472 -- Start of processing for Equivalent_Sets
475 return Is_Equivalent (Left, Right);
478 -------------------------
479 -- Equivalent_Elements --
480 -------------------------
482 function Equivalent_Elements (Left, Right : Cursor)
486 if Left.Node = 0 then
487 raise Constraint_Error with
488 "Left cursor of Equivalent_Elements equals No_Element";
491 if Right.Node = 0 then
492 raise Constraint_Error with
493 "Right cursor of Equivalent_Elements equals No_Element";
496 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
497 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
500 LN : Node_Type renames Left.Container.Nodes (Left.Node);
501 RN : Node_Type renames Right.Container.Nodes (Right.Node);
503 return Equivalent_Elements (LN.Element, RN.Element);
505 end Equivalent_Elements;
507 function Equivalent_Elements
509 Right : Element_Type) return Boolean
512 if Left.Node = 0 then
513 raise Constraint_Error with
514 "Left cursor of Equivalent_Elements equals No_Element";
517 pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad");
520 LN : Node_Type renames Left.Container.Nodes (Left.Node);
522 return Equivalent_Elements (LN.Element, Right);
524 end Equivalent_Elements;
526 function Equivalent_Elements
527 (Left : Element_Type;
528 Right : Cursor) return Boolean
531 if Right.Node = 0 then
532 raise Constraint_Error with
533 "Right cursor of Equivalent_Elements equals No_Element";
538 "Right cursor of Equivalent_Elements is bad");
541 RN : Node_Type renames Right.Container.Nodes (Right.Node);
543 return Equivalent_Elements (Left, RN.Element);
545 end Equivalent_Elements;
547 ---------------------
548 -- Equivalent_Keys --
549 ---------------------
551 function Equivalent_Keys
553 Node : Node_Type) return Boolean
556 return Equivalent_Elements (Key, Node.Element);
564 (Container : in out Set;
569 Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
570 HT_Ops.Free (Container, X);
579 Item : Element_Type) return Cursor
581 Node : constant Count_Type := Element_Keys.Find (Container, Item);
583 return (if Node = 0 then No_Element
584 else Cursor'(Container'Unrestricted_Access, Node));
591 function First (Container : Set) return Cursor is
592 Node : constant Count_Type := HT_Ops.First (Container);
594 return (if Node = 0 then No_Element
595 else Cursor'(Container'Unrestricted_Access, Node));
598 overriding function First (Object : Iterator) return Cursor is
599 Node : constant Count_Type := HT_Ops.First (Object.Container.all);
601 return (if Node = 0 then No_Element
602 else Cursor'(Object.Container, Node));
609 function Has_Element (Position : Cursor) return Boolean is
611 pragma Assert (Vet (Position), "bad cursor in Has_Element");
612 return Position.Node /= 0;
619 function Hash_Node (Node : Node_Type) return Hash_Type is
621 return Hash (Node.Element);
629 (Container : in out Set;
630 New_Item : Element_Type)
636 Insert (Container, New_Item, Position, Inserted);
639 if Container.Lock > 0 then
640 raise Program_Error with
641 "attempt to tamper with elements (set is locked)";
644 Container.Nodes (Position.Node).Element := New_Item;
653 (Container : in out Set;
654 New_Item : Element_Type;
655 Position : out Cursor;
656 Inserted : out Boolean)
659 Insert (Container, New_Item, Position.Node, Inserted);
660 Position.Container := Container'Unchecked_Access;
664 (Container : in out Set;
665 New_Item : Element_Type)
668 pragma Unreferenced (Position);
673 Insert (Container, New_Item, Position, Inserted);
676 raise Constraint_Error with
677 "attempt to insert element already in set";
682 (Container : in out Set;
683 New_Item : Element_Type;
684 Node : out Count_Type;
685 Inserted : out Boolean)
687 procedure Allocate_Set_Element (Node : in out Node_Type);
688 pragma Inline (Allocate_Set_Element);
690 function New_Node return Count_Type;
691 pragma Inline (New_Node);
693 procedure Local_Insert is
694 new Element_Keys.Generic_Conditional_Insert (New_Node);
696 procedure Allocate is
697 new HT_Ops.Generic_Allocate (Allocate_Set_Element);
699 ---------------------------
700 -- Allocate_Set_Element --
701 ---------------------------
703 procedure Allocate_Set_Element (Node : in out Node_Type) is
705 Node.Element := New_Item;
706 end Allocate_Set_Element;
712 function New_Node return Count_Type is
715 Allocate (Container, Result);
719 -- Start of processing for Insert
722 -- The buckets array length is specified by the user as a discriminant
723 -- of the container type, so it is possible for the buckets array to
724 -- have a length of zero. We must check for this case specifically, in
725 -- order to prevent divide-by-zero errors later, when we compute the
726 -- buckets array index value for an element, given its hash value.
728 if Container.Buckets'Length = 0 then
729 raise Capacity_Error with "No capacity for insertion";
732 Local_Insert (Container, New_Item, Node, Inserted);
739 procedure Intersection
740 (Target : in out Set;
743 Tgt_Node : Count_Type;
744 TN : Nodes_Type renames Target.Nodes;
747 if Target'Address = Source'Address then
751 if Source.Length = 0 then
752 HT_Ops.Clear (Target);
756 if Target.Busy > 0 then
757 raise Program_Error with
758 "attempt to tamper with cursors (set is busy)";
761 Tgt_Node := HT_Ops.First (Target);
762 while Tgt_Node /= 0 loop
763 if Is_In (Source, TN (Tgt_Node)) then
764 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
768 X : constant Count_Type := Tgt_Node;
770 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
771 HT_Ops.Delete_Node_Sans_Free (Target, X);
772 HT_Ops.Free (Target, X);
778 function Intersection (Left, Right : Set) return Set is
782 if Left'Address = Right'Address then
786 C := Count_Type'Min (Left.Length, Right.Length);
792 return Result : Set (C, To_Prime (C)) do
793 Iterate_Left : declare
794 procedure Process (L_Node : Count_Type);
797 new HT_Ops.Generic_Iteration (Process);
803 procedure Process (L_Node : Count_Type) is
804 N : Node_Type renames Left.Nodes (L_Node);
809 if Is_In (Right, N) then
810 Insert (Result, N.Element, X, B); -- optimize ???
812 pragma Assert (X > 0);
816 -- Start of processing for Iterate_Left
828 function Is_Empty (Container : Set) return Boolean is
830 return Container.Length = 0;
837 function Is_In (HT : Set; Key : Node_Type) return Boolean is
839 return Element_Keys.Find (HT, Key.Element) /= 0;
846 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
847 Subset_Node : Count_Type;
848 SN : Nodes_Type renames Subset.Nodes;
851 if Subset'Address = Of_Set'Address then
855 if Subset.Length > Of_Set.Length then
859 Subset_Node := HT_Ops.First (Subset);
860 while Subset_Node /= 0 loop
861 if not Is_In (Of_Set, SN (Subset_Node)) then
864 Subset_Node := HT_Ops.Next (Subset, Subset_Node);
876 Process : not null access procedure (Position : Cursor))
878 procedure Process_Node (Node : Count_Type);
879 pragma Inline (Process_Node);
882 new HT_Ops.Generic_Iteration (Process_Node);
888 procedure Process_Node (Node : Count_Type) is
890 Process (Cursor'(Container'Unrestricted_Access, Node));
893 B : Natural renames Container'Unrestricted_Access.Busy;
895 -- Start of processing for Iterate
911 function Iterate (Container : Set)
912 return Set_Iterator_Interfaces.Forward_Iterator'Class is
914 return Iterator'(Container'Unrestricted_Access, First (Container));
921 function Length (Container : Set) return Count_Type is
923 return Container.Length;
930 procedure Move (Target : in out Set; Source : in out Set) is
932 if Target'Address = Source'Address then
936 if Source.Busy > 0 then
937 raise Program_Error with
938 "attempt to tamper with cursors (container is busy)";
941 Target.Assign (Source);
949 function Next (Node : Node_Type) return Count_Type is
954 function Next (Position : Cursor) return Cursor is
956 if Position.Node = 0 then
960 pragma Assert (Vet (Position), "bad cursor in Next");
963 HT : Set renames Position.Container.all;
964 Node : constant Count_Type := HT_Ops.Next (HT, Position.Node);
971 return Cursor'(Position.Container, Node);
975 procedure Next (Position : in out Cursor) is
977 Position := Next (Position);
982 Position : Cursor) return Cursor
985 if Position.Container /= Object.Container then
986 raise Program_Error with
987 "Position cursor designates wrong set";
990 return (if Position.Node = 0 then No_Element else Next (Position));
997 function Overlap (Left, Right : Set) return Boolean is
998 Left_Node : Count_Type;
1001 if Right.Length = 0 then
1005 if Left'Address = Right'Address then
1009 Left_Node := HT_Ops.First (Left);
1010 while Left_Node /= 0 loop
1011 if Is_In (Right, Left.Nodes (Left_Node)) then
1014 Left_Node := HT_Ops.Next (Left, Left_Node);
1024 procedure Query_Element
1026 Process : not null access procedure (Element : Element_Type))
1029 if Position.Node = 0 then
1030 raise Constraint_Error with
1031 "Position cursor of Query_Element equals No_Element";
1034 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1037 S : Set renames Position.Container.all;
1038 B : Natural renames S.Busy;
1039 L : Natural renames S.Lock;
1046 Process (S.Nodes (Position.Node).Element);
1064 (Stream : not null access Root_Stream_Type'Class;
1065 Container : out Set)
1067 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1070 procedure Read_Nodes is
1071 new HT_Ops.Generic_Read (Read_Node);
1077 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1080 procedure Read_Element (Node : in out Node_Type);
1081 pragma Inline (Read_Element);
1083 procedure Allocate is
1084 new HT_Ops.Generic_Allocate (Read_Element);
1086 procedure Read_Element (Node : in out Node_Type) is
1088 Element_Type'Read (Stream, Node.Element);
1093 -- Start of processing for Read_Node
1096 Allocate (Container, Node);
1100 -- Start of processing for Read
1103 Read_Nodes (Stream, Container);
1107 (Stream : not null access Root_Stream_Type'Class;
1111 raise Program_Error with "attempt to stream set cursor";
1115 (Stream : not null access Root_Stream_Type'Class;
1116 Item : out Constant_Reference_Type)
1119 raise Program_Error with "attempt to stream reference";
1126 function Constant_Reference
1127 (Container : aliased Set;
1128 Position : Cursor) return Constant_Reference_Type
1130 pragma Unreferenced (Container);
1131 S : Set renames Position.Container.all;
1132 N : Node_Type renames S.Nodes (Position.Node);
1134 return (Element => N.Element'Unrestricted_Access);
1135 end Constant_Reference;
1142 (Container : in out Set;
1143 New_Item : Element_Type)
1145 Node : constant Count_Type :=
1146 Element_Keys.Find (Container, New_Item);
1150 raise Constraint_Error with
1151 "attempt to replace element not in set";
1154 if Container.Lock > 0 then
1155 raise Program_Error with
1156 "attempt to tamper with elements (set is locked)";
1159 Container.Nodes (Node).Element := New_Item;
1162 procedure Replace_Element
1163 (Container : in out Set;
1165 New_Item : Element_Type)
1168 if Position.Node = 0 then
1169 raise Constraint_Error with
1170 "Position cursor equals No_Element";
1173 if Position.Container /= Container'Unrestricted_Access then
1174 raise Program_Error with
1175 "Position cursor designates wrong set";
1178 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1180 Replace_Element (Container, Position.Node, New_Item);
1181 end Replace_Element;
1183 ----------------------
1184 -- Reserve_Capacity --
1185 ----------------------
1187 procedure Reserve_Capacity
1188 (Container : in out Set;
1189 Capacity : Count_Type)
1192 if Capacity > Container.Capacity then
1193 raise Capacity_Error with "requested capacity is too large";
1195 end Reserve_Capacity;
1201 procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is
1203 Node.Element := Item;
1210 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
1215 --------------------------
1216 -- Symmetric_Difference --
1217 --------------------------
1219 procedure Symmetric_Difference
1220 (Target : in out Set;
1223 procedure Process (Source_Node : Count_Type);
1224 pragma Inline (Process);
1226 procedure Iterate is
1227 new HT_Ops.Generic_Iteration (Process);
1233 procedure Process (Source_Node : Count_Type) is
1234 N : Node_Type renames Source.Nodes (Source_Node);
1239 if Is_In (Target, N) then
1240 Delete (Target, N.Element);
1242 Insert (Target, N.Element, X, B);
1247 -- Start of processing for Symmetric_Difference
1250 if Target'Address = Source'Address then
1251 HT_Ops.Clear (Target);
1255 if Target.Length = 0 then
1256 Assign (Target => Target, Source => Source);
1260 if Target.Busy > 0 then
1261 raise Program_Error with
1262 "attempt to tamper with cursors (set is busy)";
1266 end Symmetric_Difference;
1268 function Symmetric_Difference (Left, Right : Set) return Set is
1272 if Left'Address = Right'Address then
1276 if Right.Length = 0 then
1280 if Left.Length = 0 then
1284 C := Left.Length + Right.Length;
1286 return Result : Set (C, To_Prime (C)) do
1287 Iterate_Left : declare
1288 procedure Process (L_Node : Count_Type);
1290 procedure Iterate is
1291 new HT_Ops.Generic_Iteration (Process);
1297 procedure Process (L_Node : Count_Type) is
1298 N : Node_Type renames Left.Nodes (L_Node);
1302 if not Is_In (Right, N) then
1303 Insert (Result, N.Element, X, B);
1308 -- Start of processing for Iterate_Left
1314 Iterate_Right : declare
1315 procedure Process (R_Node : Count_Type);
1317 procedure Iterate is
1318 new HT_Ops.Generic_Iteration (Process);
1324 procedure Process (R_Node : Count_Type) is
1325 N : Node_Type renames Right.Nodes (R_Node);
1329 if not Is_In (Left, N) then
1330 Insert (Result, N.Element, X, B);
1335 -- Start of processing for Iterate_Right
1341 end Symmetric_Difference;
1347 function To_Set (New_Item : Element_Type) return Set is
1351 return Result : Set (1, 1) do
1352 Insert (Result, New_Item, X, B);
1362 (Target : in out Set;
1365 procedure Process (Src_Node : Count_Type);
1367 procedure Iterate is
1368 new HT_Ops.Generic_Iteration (Process);
1374 procedure Process (Src_Node : Count_Type) is
1375 N : Node_Type renames Source.Nodes (Src_Node);
1379 Insert (Target, N.Element, X, B);
1382 -- Start of processing for Union
1385 if Target'Address = Source'Address then
1389 if Target.Busy > 0 then
1390 raise Program_Error with
1391 "attempt to tamper with cursors (set is busy)";
1394 -- ??? why is this code commented out ???
1396 -- N : constant Count_Type := Target.Length + Source.Length;
1398 -- if N > HT_Ops.Capacity (Target.HT) then
1399 -- HT_Ops.Reserve_Capacity (Target.HT, N);
1406 function Union (Left, Right : Set) return Set is
1410 if Left'Address = Right'Address then
1414 if Right.Length = 0 then
1418 if Left.Length = 0 then
1422 C := Left.Length + Right.Length;
1424 return Result : Set (C, To_Prime (C)) do
1425 Assign (Target => Result, Source => Left);
1426 Union (Target => Result, Source => Right);
1434 function Vet (Position : Cursor) return Boolean is
1436 if Position.Node = 0 then
1437 return Position.Container = null;
1440 if Position.Container = null then
1445 S : Set renames Position.Container.all;
1446 N : Nodes_Type renames S.Nodes;
1450 if S.Length = 0 then
1454 if Position.Node > N'Last then
1458 if N (Position.Node).Next = Position.Node then
1462 X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element));
1464 for J in 1 .. S.Length loop
1465 if X = Position.Node then
1473 if X = N (X).Next then -- to prevent unnecessary looping
1489 (Stream : not null access Root_Stream_Type'Class;
1492 procedure Write_Node
1493 (Stream : not null access Root_Stream_Type'Class;
1495 pragma Inline (Write_Node);
1497 procedure Write_Nodes is
1498 new HT_Ops.Generic_Write (Write_Node);
1504 procedure Write_Node
1505 (Stream : not null access Root_Stream_Type'Class;
1509 Element_Type'Write (Stream, Node.Element);
1512 -- Start of processing for Write
1515 Write_Nodes (Stream, Container);
1519 (Stream : not null access Root_Stream_Type'Class;
1523 raise Program_Error with "attempt to stream set cursor";
1527 (Stream : not null access Root_Stream_Type'Class;
1528 Item : Constant_Reference_Type)
1531 raise Program_Error with "attempt to stream reference";
1534 package body Generic_Keys is
1536 -----------------------
1537 -- Local Subprograms --
1538 -----------------------
1540 function Equivalent_Key_Node
1542 Node : Node_Type) return Boolean;
1543 pragma Inline (Equivalent_Key_Node);
1545 --------------------------
1546 -- Local Instantiations --
1547 --------------------------
1550 new Hash_Tables.Generic_Bounded_Keys
1551 (HT_Types => HT_Types,
1553 Set_Next => Set_Next,
1554 Key_Type => Key_Type,
1556 Equivalent_Keys => Equivalent_Key_Node);
1564 Key : Key_Type) return Boolean
1567 return Find (Container, Key) /= No_Element;
1575 (Container : in out Set;
1581 Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1584 raise Constraint_Error with "attempt to delete key not in set";
1587 HT_Ops.Free (Container, X);
1596 Key : Key_Type) return Element_Type
1598 Node : constant Count_Type := Key_Keys.Find (Container, Key);
1602 raise Constraint_Error with "key not in map";
1605 return Container.Nodes (Node).Element;
1608 -------------------------
1609 -- Equivalent_Key_Node --
1610 -------------------------
1612 function Equivalent_Key_Node
1614 Node : Node_Type) return Boolean
1617 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1618 end Equivalent_Key_Node;
1625 (Container : in out Set;
1630 Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1631 HT_Ops.Free (Container, X);
1640 Key : Key_Type) return Cursor
1642 Node : constant Count_Type := Key_Keys.Find (Container, Key);
1644 return (if Node = 0 then No_Element
1645 else Cursor'(Container'Unrestricted_Access, Node));
1652 function Key (Position : Cursor) return Key_Type is
1654 if Position.Node = 0 then
1655 raise Constraint_Error with
1656 "Position cursor equals No_Element";
1659 pragma Assert (Vet (Position), "bad cursor in function Key");
1660 return Key (Position.Container.Nodes (Position.Node).Element);
1668 (Container : in out Set;
1670 New_Item : Element_Type)
1672 Node : constant Count_Type := Key_Keys.Find (Container, Key);
1676 raise Constraint_Error with
1677 "attempt to replace key not in set";
1680 Replace_Element (Container, Node, New_Item);
1683 -----------------------------------
1684 -- Update_Element_Preserving_Key --
1685 -----------------------------------
1687 procedure Update_Element_Preserving_Key
1688 (Container : in out Set;
1690 Process : not null access
1691 procedure (Element : in out Element_Type))
1694 N : Nodes_Type renames Container.Nodes;
1697 if Position.Node = 0 then
1698 raise Constraint_Error with
1699 "Position cursor equals No_Element";
1702 if Position.Container /= Container'Unrestricted_Access then
1703 raise Program_Error with
1704 "Position cursor designates wrong set";
1707 -- ??? why is this code commented out ???
1708 -- if HT.Buckets = null
1709 -- or else HT.Buckets'Length = 0
1710 -- or else HT.Length = 0
1711 -- or else Position.Node.Next = Position.Node
1713 -- raise Program_Error with
1714 -- "Position cursor is bad (set is empty)";
1719 "bad cursor in Update_Element_Preserving_Key");
1721 -- Record bucket now, in case key is changed
1723 Indx := HT_Ops.Index (Container.Buckets, N (Position.Node));
1726 E : Element_Type renames N (Position.Node).Element;
1727 K : constant Key_Type := Key (E);
1729 B : Natural renames Container.Busy;
1730 L : Natural renames Container.Lock;
1748 if Equivalent_Keys (K, Key (E)) then
1749 pragma Assert (Hash (K) = Hash (E));
1754 -- Key was modified, so remove this node from set.
1756 if Container.Buckets (Indx) = Position.Node then
1757 Container.Buckets (Indx) := N (Position.Node).Next;
1761 Prev : Count_Type := Container.Buckets (Indx);
1764 while N (Prev).Next /= Position.Node loop
1765 Prev := N (Prev).Next;
1768 raise Program_Error with
1769 "Position cursor is bad (node not found)";
1773 N (Prev).Next := N (Position.Node).Next;
1777 Container.Length := Container.Length - 1;
1778 HT_Ops.Free (Container, Position.Node);
1780 raise Program_Error with "key was modified";
1781 end Update_Element_Preserving_Key;
1783 ------------------------------
1784 -- Reference_Preserving_Key --
1785 ------------------------------
1787 function Reference_Preserving_Key
1788 (Container : aliased in out Set;
1789 Position : Cursor) return Reference_Type
1791 N : Node_Type renames Container.Nodes (Position.Node);
1793 return (Element => N.Element'Unrestricted_Access);
1794 end Reference_Preserving_Key;
1796 function Reference_Preserving_Key
1797 (Container : aliased in out Set;
1798 Key : Key_Type) return Reference_Type
1800 Position : constant Cursor := Find (Container, Key);
1801 N : Node_Type renames Container.Nodes (Position.Node);
1803 return (Element => N.Element'Unrestricted_Access);
1804 end Reference_Preserving_Key;
1808 end Ada.Containers.Bounded_Hashed_Sets;