1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S --
9 -- Copyright (C) 2010-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/>. --
26 ------------------------------------------------------------------------------
28 with Ada.Containers.Hash_Tables.Generic_Bounded_Operations;
29 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
31 with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
32 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
34 with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
36 with System; use type System.Address;
38 package body Ada.Containers.Formal_Hashed_Sets is
40 -----------------------
41 -- Local Subprograms --
42 -----------------------
44 -- All need comments ???
50 function Equivalent_Keys
52 Node : Node_Type) return Boolean;
53 pragma Inline (Equivalent_Keys);
60 with procedure Set_Element (Node : in out Node_Type);
61 procedure Generic_Allocate
63 Node : out Count_Type);
65 function Hash_Node (Node : Node_Type) return Hash_Type;
66 pragma Inline (Hash_Node);
69 (Container : in out Set;
70 New_Item : Element_Type;
71 Node : out Count_Type;
72 Inserted : out Boolean);
74 procedure Intersection
81 Key : Node_Type) return Boolean;
82 pragma Inline (Is_In);
84 procedure Set_Element (Node : in out Node_Type; Item : Element_Type);
85 pragma Inline (Set_Element);
87 function Next (Node : Node_Type) return Count_Type;
90 procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
91 pragma Inline (Set_Next);
93 function Vet (Container : Set; Position : Cursor) return Boolean;
95 --------------------------
96 -- Local Instantiations --
97 --------------------------
99 package HT_Ops is new Hash_Tables.Generic_Bounded_Operations
100 (HT_Types => HT_Types,
101 Hash_Node => Hash_Node,
103 Set_Next => Set_Next);
105 package Element_Keys is new Hash_Tables.Generic_Bounded_Keys
106 (HT_Types => HT_Types,
108 Set_Next => Set_Next,
109 Key_Type => Element_Type,
111 Equivalent_Keys => Equivalent_Keys);
113 procedure Replace_Element is
114 new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element);
120 function "=" (Left, Right : Set) return Boolean is
122 if Length (Left) /= Length (Right) then
126 if Length (Left) = 0 then
135 Node := First (Left).Node;
137 ENode := Find (Container => Right,
138 Item => Left.Nodes (Node).Element).Node;
140 Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
145 Node := HT_Ops.Next (Left, Node);
158 procedure Assign (Target : in out Set; Source : Set) is
159 procedure Insert_Element (Source_Node : Count_Type);
161 procedure Insert_Elements is
162 new HT_Ops.Generic_Iteration (Insert_Element);
168 procedure Insert_Element (Source_Node : Count_Type) is
169 N : Node_Type renames Source.Nodes (Source_Node);
174 Insert (Target, N.Element, X, B);
178 -- Start of processing for Assign
181 if Target'Address = Source'Address then
185 if Target.Capacity < Length (Source) then
186 raise Storage_Error with "not enough capacity"; -- SE or CE? ???
189 HT_Ops.Clear (Target);
190 Insert_Elements (Source);
197 function Capacity (Container : Set) return Count_Type is
199 return Container.Nodes'Length;
206 procedure Clear (Container : in out Set) is
208 HT_Ops.Clear (Container);
215 function Contains (Container : Set; Item : Element_Type) return Boolean is
217 return Find (Container, Item) /= No_Element;
226 Capacity : Count_Type := 0) return Set
228 C : constant Count_Type :=
229 Count_Type'Max (Capacity, Source.Capacity);
232 Target : Set (C, Source.Modulus);
236 Target.Length := Source.Length;
237 Target.Free := Source.Free;
240 while H <= Source.Modulus loop
241 Target.Buckets (H) := Source.Buckets (H);
246 while N <= Source.Capacity loop
247 Target.Nodes (N) := Source.Nodes (N);
253 Free (Target, Cu.Node);
260 ---------------------
261 -- Default_Modulus --
262 ---------------------
264 function Default_Modulus (Capacity : Count_Type) return Hash_Type is
266 return To_Prime (Capacity);
274 (Container : in out Set;
280 Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
283 raise Constraint_Error with "attempt to delete element not in set";
290 (Container : in out Set;
291 Position : in out Cursor)
294 if not Has_Element (Container, Position) then
295 raise Constraint_Error with "Position cursor has no element";
298 if Container.Busy > 0 then
299 raise Program_Error with
300 "attempt to tamper with elements (set is busy)";
303 pragma Assert (Vet (Container, Position), "bad cursor in Delete");
305 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
306 Free (Container, Position.Node);
308 Position := No_Element;
316 (Target : in out Set;
319 Tgt_Node, Src_Node, Src_Last, Src_Length : Count_Type;
321 TN : Nodes_Type renames Target.Nodes;
322 SN : Nodes_Type renames Source.Nodes;
325 if Target'Address = Source'Address then
330 Src_Length := Source.Length;
332 if Src_Length = 0 then
336 if Target.Busy > 0 then
337 raise Program_Error with
338 "attempt to tamper with elements (set is busy)";
341 if Src_Length >= Target.Length then
342 Tgt_Node := HT_Ops.First (Target);
343 while Tgt_Node /= 0 loop
344 if Element_Keys.Find (Source, TN (Tgt_Node).Element) /= 0 then
346 X : constant Count_Type := Tgt_Node;
348 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
349 HT_Ops.Delete_Node_Sans_Free (Target, X);
354 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
360 Src_Node := HT_Ops.First (Source);
364 while Src_Node /= Src_Last loop
365 Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element);
367 if Tgt_Node /= 0 then
368 HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node);
369 Free (Target, Tgt_Node);
372 Src_Node := HT_Ops.Next (Source, Src_Node);
380 procedure Process (L_Node : Count_Type);
383 new HT_Ops.Generic_Iteration (Process);
389 procedure Process (L_Node : Count_Type) is
390 E : Element_Type renames Left.Nodes (L_Node).Element;
394 if Find (Right, E).Node = 0 then
395 Insert (Target, E, X, B);
400 -- Start of processing for Difference
406 function Difference (Left, Right : Set) return Set is
411 if Left'Address = Right'Address then
415 if Length (Left) = 0 then
419 if Length (Right) = 0 then
424 H := Default_Modulus (C);
426 return S : Set (C, H) do
427 Difference (Left, Right, Target => S);
437 Position : Cursor) return Element_Type
440 if not Has_Element (Container, Position) then
441 raise Constraint_Error with "Position cursor equals No_Element";
444 pragma Assert (Vet (Container, Position),
445 "bad cursor in function Element");
447 return Container.Nodes (Position.Node).Element;
450 ---------------------
451 -- Equivalent_Sets --
452 ---------------------
454 function Equivalent_Sets (Left, Right : Set) return Boolean is
456 function Find_Equivalent_Key
457 (R_HT : Hash_Table_Type'Class;
458 L_Node : Node_Type) return Boolean;
459 pragma Inline (Find_Equivalent_Key);
461 function Is_Equivalent is
462 new HT_Ops.Generic_Equal (Find_Equivalent_Key);
464 -------------------------
465 -- Find_Equivalent_Key --
466 -------------------------
468 function Find_Equivalent_Key
469 (R_HT : Hash_Table_Type'Class;
470 L_Node : Node_Type) return Boolean
472 R_Index : constant Hash_Type :=
473 Element_Keys.Index (R_HT, L_Node.Element);
474 R_Node : Count_Type := R_HT.Buckets (R_Index);
475 RN : Nodes_Type renames R_HT.Nodes;
483 if Equivalent_Elements (L_Node.Element,
484 RN (R_Node).Element) then
488 R_Node := HT_Ops.Next (R_HT, R_Node);
490 end Find_Equivalent_Key;
492 -- Start of processing of Equivalent_Sets
495 return Is_Equivalent (Left, Right);
498 -------------------------
499 -- Equivalent_Elements --
500 -------------------------
502 function Equivalent_Elements
506 CRight : Cursor) return Boolean
509 if not Has_Element (Left, CLeft) then
510 raise Constraint_Error with
511 "Left cursor of Equivalent_Elements has no element";
514 if not Has_Element (Right, CRight) then
515 raise Constraint_Error with
516 "Right cursor of Equivalent_Elements has no element";
519 pragma Assert (Vet (Left, CLeft),
520 "bad Left cursor in Equivalent_Elements");
521 pragma Assert (Vet (Right, CRight),
522 "bad Right cursor in Equivalent_Elements");
525 LN : Node_Type renames Left.Nodes (CLeft.Node);
526 RN : Node_Type renames Right.Nodes (CRight.Node);
528 return Equivalent_Elements (LN.Element, RN.Element);
530 end Equivalent_Elements;
532 function Equivalent_Elements
535 Right : Element_Type) return Boolean
538 if not Has_Element (Left, CLeft) then
539 raise Constraint_Error with
540 "Left cursor of Equivalent_Elements has no element";
543 pragma Assert (Vet (Left, CLeft),
544 "Left cursor in Equivalent_Elements is bad");
547 LN : Node_Type renames Left.Nodes (CLeft.Node);
549 return Equivalent_Elements (LN.Element, Right);
551 end Equivalent_Elements;
553 function Equivalent_Elements
554 (Left : Element_Type;
556 CRight : Cursor) return Boolean
559 if not Has_Element (Right, CRight) then
560 raise Constraint_Error with
561 "Right cursor of Equivalent_Elements has no element";
565 (Vet (Right, CRight),
566 "Right cursor of Equivalent_Elements is bad");
569 RN : Node_Type renames Right.Nodes (CRight.Node);
571 return Equivalent_Elements (Left, RN.Element);
573 end Equivalent_Elements;
575 -- What does the following comment signify???
578 ---------------------
579 -- Equivalent_Keys --
580 ---------------------
582 function Equivalent_Keys
584 Node : Node_Type) return Boolean
587 return Equivalent_Elements (Key, Node.Element);
595 (Container : in out Set;
600 Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
610 Item : Element_Type) return Cursor
612 Node : constant Count_Type := Element_Keys.Find (Container, Item);
619 return (Node => Node);
626 function First (Container : Set) return Cursor is
627 Node : constant Count_Type := HT_Ops.First (Container);
634 return (Node => Node);
646 HT.Nodes (X).Has_Element := False;
650 ----------------------
651 -- Generic_Allocate --
652 ----------------------
654 procedure Generic_Allocate
656 Node : out Count_Type)
658 procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element);
661 HT.Nodes (Node).Has_Element := True;
662 end Generic_Allocate;
668 function Has_Element (Container : Set; Position : Cursor) return Boolean is
671 or else not Container.Nodes (Position.Node).Has_Element
683 function Hash_Node (Node : Node_Type) return Hash_Type is
685 return Hash (Node.Element);
693 (Container : in out Set;
694 New_Item : Element_Type)
700 Insert (Container, New_Item, Position, Inserted);
703 if Container.Lock > 0 then
704 raise Program_Error with
705 "attempt to tamper with cursors (set is locked)";
708 Container.Nodes (Position.Node).Element := New_Item;
717 (Container : in out Set;
718 New_Item : Element_Type;
719 Position : out Cursor;
720 Inserted : out Boolean)
723 Insert (Container, New_Item, Position.Node, Inserted);
727 (Container : in out Set;
728 New_Item : Element_Type)
734 Insert (Container, New_Item, Position, Inserted);
737 raise Constraint_Error with
738 "attempt to insert element already in set";
743 (Container : in out Set;
744 New_Item : Element_Type;
745 Node : out Count_Type;
746 Inserted : out Boolean)
748 procedure Allocate_Set_Element (Node : in out Node_Type);
749 pragma Inline (Allocate_Set_Element);
751 function New_Node return Count_Type;
752 pragma Inline (New_Node);
754 procedure Local_Insert is
755 new Element_Keys.Generic_Conditional_Insert (New_Node);
757 procedure Allocate is
758 new Generic_Allocate (Allocate_Set_Element);
760 ---------------------------
761 -- Allocate_Set_Element --
762 ---------------------------
764 procedure Allocate_Set_Element (Node : in out Node_Type) is
766 Node.Element := New_Item;
767 end Allocate_Set_Element;
773 function New_Node return Count_Type is
776 Allocate (Container, Result);
780 -- Start of processing for Insert
783 Local_Insert (Container, New_Item, Node, Inserted);
790 procedure Intersection
791 (Target : in out Set;
794 Tgt_Node : Count_Type;
795 TN : Nodes_Type renames Target.Nodes;
798 if Target'Address = Source'Address then
802 if Source.Length = 0 then
807 if Target.Busy > 0 then
808 raise Program_Error with
809 "attempt to tamper with elements (set is busy)";
812 Tgt_Node := HT_Ops.First (Target);
813 while Tgt_Node /= 0 loop
814 if Find (Source, TN (Tgt_Node).Element).Node /= 0 then
815 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
819 X : constant Count_Type := Tgt_Node;
821 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
822 HT_Ops.Delete_Node_Sans_Free (Target, X);
829 procedure Intersection
834 procedure Process (L_Node : Count_Type);
837 new HT_Ops.Generic_Iteration (Process);
843 procedure Process (L_Node : Count_Type) is
844 E : Element_Type renames Left.Nodes (L_Node).Element;
849 if Find (Right, E).Node /= 0 then
850 Insert (Target, E, X, B);
855 -- Start of processing for Intersection
861 function Intersection (Left, Right : Set) return Set is
866 if Left'Address = Right'Address then
870 C := Count_Type'Min (Length (Left), Length (Right)); -- ???
871 H := Default_Modulus (C);
873 return S : Set (C, H) do
874 if Length (Left) /= 0 and Length (Right) /= 0 then
875 Intersection (Left, Right, Target => S);
884 function Is_Empty (Container : Set) return Boolean is
886 return Length (Container) = 0;
893 function Is_In (HT : Set; Key : Node_Type) return Boolean is
895 return Element_Keys.Find (HT, Key.Element) /= 0;
902 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
903 Subset_Node : Count_Type;
904 Subset_Nodes : Nodes_Type renames Subset.Nodes;
907 if Subset'Address = Of_Set'Address then
911 if Length (Subset) > Length (Of_Set) then
915 Subset_Node := First (Subset).Node;
916 while Subset_Node /= 0 loop
918 N : Node_Type renames Subset_Nodes (Subset_Node);
919 E : Element_Type renames N.Element;
922 if Find (Of_Set, E).Node = 0 then
927 Subset_Node := HT_Ops.Next (Subset, Subset_Node);
940 not null access procedure (Container : Set; Position : Cursor))
942 procedure Process_Node (Node : Count_Type);
943 pragma Inline (Process_Node);
946 new HT_Ops.Generic_Iteration (Process_Node);
952 procedure Process_Node (Node : Count_Type) is
954 Process (Container, (Node => Node));
957 B : Natural renames Container'Unrestricted_Access.Busy;
959 -- Start of processing for Iterate
979 function Left (Container : Set; Position : Cursor) return Set is
980 Curs : Cursor := Position;
981 C : Set (Container.Capacity, Container.Modulus) :=
982 Copy (Container, Container.Capacity);
986 if Curs = No_Element then
990 if not Has_Element (Container, Curs) then
991 raise Constraint_Error;
994 while Curs.Node /= 0 loop
997 Curs := Next (Container, (Node => Node));
1007 function Length (Container : Set) return Count_Type is
1009 return Container.Length;
1018 procedure Move (Target : in out Set; Source : in out Set) is
1019 NN : HT_Types.Nodes_Type renames Source.Nodes;
1023 if Target'Address = Source'Address then
1027 if Target.Capacity < Length (Source) then
1028 raise Constraint_Error with -- ???
1029 "Source length exceeds Target capacity";
1032 if Source.Busy > 0 then
1033 raise Program_Error with
1034 "attempt to tamper with cursors of Source (list is busy)";
1039 if Source.Length = 0 then
1043 X := HT_Ops.First (Source);
1045 Insert (Target, NN (X).Element); -- optimize???
1047 Y := HT_Ops.Next (Source, X);
1049 HT_Ops.Delete_Node_Sans_Free (Source, X);
1060 function Next (Node : Node_Type) return Count_Type is
1065 function Next (Container : Set; Position : Cursor) return Cursor is
1067 if Position.Node = 0 then
1071 if not Has_Element (Container, Position) then
1072 raise Constraint_Error
1073 with "Position has no element";
1076 pragma Assert (Vet (Container, Position), "bad cursor in Next");
1078 return (Node => HT_Ops.Next (Container, Position.Node));
1081 procedure Next (Container : Set; Position : in out Cursor) is
1083 Position := Next (Container, Position);
1090 function Overlap (Left, Right : Set) return Boolean is
1091 Left_Node : Count_Type;
1092 Left_Nodes : Nodes_Type renames Left.Nodes;
1095 if Length (Right) = 0 or Length (Left) = 0 then
1099 if Left'Address = Right'Address then
1103 Left_Node := First (Left).Node;
1104 while Left_Node /= 0 loop
1106 N : Node_Type renames Left_Nodes (Left_Node);
1107 E : Element_Type renames N.Element;
1109 if Find (Right, E).Node /= 0 then
1114 Left_Node := HT_Ops.Next (Left, Left_Node);
1124 procedure Query_Element
1125 (Container : in out Set;
1127 Process : not null access procedure (Element : Element_Type))
1130 if not Has_Element (Container, Position) then
1131 raise Constraint_Error with
1132 "Position cursor of Query_Element has no element";
1135 pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
1138 B : Natural renames Container.Busy;
1139 L : Natural renames Container.Lock;
1146 Process (Container.Nodes (Position.Node).Element);
1164 (Stream : not null access Root_Stream_Type'Class;
1165 Container : out Set)
1167 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1170 procedure Read_Nodes is
1171 new HT_Ops.Generic_Read (Read_Node);
1177 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1180 procedure Read_Element (Node : in out Node_Type);
1181 pragma Inline (Read_Element);
1183 procedure Allocate is new Generic_Allocate (Read_Element);
1189 procedure Read_Element (Node : in out Node_Type) is
1191 Element_Type'Read (Stream, Node.Element);
1196 -- Start of processing for Read_Node
1199 Allocate (Container, Node);
1203 -- Start of processing for Read
1206 Read_Nodes (Stream, Container);
1210 (Stream : not null access Root_Stream_Type'Class;
1214 raise Program_Error with "attempt to stream set cursor";
1222 (Container : in out Set;
1223 New_Item : Element_Type)
1225 Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
1229 raise Constraint_Error with
1230 "attempt to replace element not in set";
1233 if Container.Lock > 0 then
1234 raise Program_Error with
1235 "attempt to tamper with cursors (set is locked)";
1238 Container.Nodes (Node).Element := New_Item;
1241 ---------------------
1242 -- Replace_Element --
1243 ---------------------
1245 procedure Replace_Element
1246 (Container : in out Set;
1248 New_Item : Element_Type)
1251 if not Has_Element (Container, Position) then
1252 raise Constraint_Error with
1253 "Position cursor equals No_Element";
1256 pragma Assert (Vet (Container, Position),
1257 "bad cursor in Replace_Element");
1259 Replace_Element (Container, Position.Node, New_Item);
1260 end Replace_Element;
1262 ----------------------
1263 -- Reserve_Capacity --
1264 ----------------------
1266 procedure Reserve_Capacity
1267 (Container : in out Set;
1268 Capacity : Count_Type)
1271 if Capacity > Container.Capacity then
1272 raise Constraint_Error with "requested capacity is too large";
1274 end Reserve_Capacity;
1280 function Right (Container : Set; Position : Cursor) return Set is
1281 Curs : Cursor := First (Container);
1282 C : Set (Container.Capacity, Container.Modulus) :=
1283 Copy (Container, Container.Capacity);
1287 if Curs = No_Element then
1292 if Position /= No_Element and not Has_Element (Container, Position) then
1293 raise Constraint_Error;
1296 while Curs.Node /= Position.Node loop
1299 Curs := Next (Container, (Node => Node));
1309 procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is
1311 Node.Element := Item;
1318 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
1327 function Strict_Equal (Left, Right : Set) return Boolean is
1328 CuL : Cursor := First (Left);
1329 CuR : Cursor := First (Right);
1332 if Length (Left) /= Length (Right) then
1336 while CuL.Node /= 0 or CuR.Node /= 0 loop
1337 if CuL.Node /= CuR.Node
1338 or else Left.Nodes (CuL.Node).Element /=
1339 Right.Nodes (CuR.Node).Element
1344 CuL := Next (Left, CuL);
1345 CuR := Next (Right, CuR);
1351 --------------------------
1352 -- Symmetric_Difference --
1353 --------------------------
1355 procedure Symmetric_Difference
1356 (Target : in out Set;
1359 procedure Process (Source_Node : Count_Type);
1360 pragma Inline (Process);
1362 procedure Iterate is new HT_Ops.Generic_Iteration (Process);
1368 procedure Process (Source_Node : Count_Type) is
1369 N : Node_Type renames Source.Nodes (Source_Node);
1373 if Is_In (Target, N) then
1374 Delete (Target, N.Element);
1376 Insert (Target, N.Element, X, B);
1381 -- Start of processing for Symmetric_Difference
1384 if Target'Address = Source'Address then
1389 if Length (Target) = 0 then
1390 Assign (Target, Source);
1394 if Target.Busy > 0 then
1395 raise Program_Error with
1396 "attempt to tamper with elements (set is busy)";
1400 end Symmetric_Difference;
1402 function Symmetric_Difference (Left, Right : Set) return Set is
1407 if Left'Address = Right'Address then
1411 if Length (Right) = 0 then
1415 if Length (Left) = 0 then
1419 C := Length (Left) + Length (Right);
1420 H := Default_Modulus (C);
1422 return S : Set (C, H) do
1423 Difference (Left, Right, S);
1424 Difference (Right, Left, S);
1426 end Symmetric_Difference;
1432 function To_Set (New_Item : Element_Type) return Set is
1437 return S : Set (Capacity => 1, Modulus => 1) do
1438 Insert (S, New_Item, X, B);
1448 (Target : in out Set;
1451 procedure Process (Src_Node : Count_Type);
1453 procedure Iterate is
1454 new HT_Ops.Generic_Iteration (Process);
1460 procedure Process (Src_Node : Count_Type) is
1461 N : Node_Type renames Source.Nodes (Src_Node);
1462 E : Element_Type renames N.Element;
1468 Insert (Target, E, X, B);
1471 -- Start of processing for Union
1475 if Target'Address = Source'Address then
1479 if Target.Busy > 0 then
1480 raise Program_Error with
1481 "attempt to tamper with elements (set is busy)";
1486 function Union (Left, Right : Set) return Set is
1491 if Left'Address = Right'Address then
1495 if Length (Right) = 0 then
1499 if Length (Left) = 0 then
1503 C := Length (Left) + Length (Right);
1504 H := Default_Modulus (C);
1505 return S : Set (C, H) do
1506 Assign (Target => S, Source => Left);
1507 Union (Target => S, Source => Right);
1515 function Vet (Container : Set; Position : Cursor) return Boolean is
1517 if Position.Node = 0 then
1522 S : Set renames Container;
1523 N : Nodes_Type renames S.Nodes;
1527 if S.Length = 0 then
1531 if Position.Node > N'Last then
1535 if N (Position.Node).Next = Position.Node then
1539 X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element));
1541 for J in 1 .. S.Length loop
1542 if X = Position.Node then
1550 if X = N (X).Next then -- to prevent unnecessary looping
1566 (Stream : not null access Root_Stream_Type'Class;
1569 procedure Write_Node
1570 (Stream : not null access Root_Stream_Type'Class;
1572 pragma Inline (Write_Node);
1574 procedure Write_Nodes is
1575 new HT_Ops.Generic_Write (Write_Node);
1581 procedure Write_Node
1582 (Stream : not null access Root_Stream_Type'Class;
1586 Element_Type'Write (Stream, Node.Element);
1589 -- Start of processing for Write
1592 Write_Nodes (Stream, Container);
1596 (Stream : not null access Root_Stream_Type'Class;
1600 raise Program_Error with "attempt to stream set cursor";
1602 package body Generic_Keys is
1604 -----------------------
1605 -- Local Subprograms --
1606 -----------------------
1608 function Equivalent_Key_Node
1610 Node : Node_Type) return Boolean;
1611 pragma Inline (Equivalent_Key_Node);
1613 --------------------------
1614 -- Local Instantiations --
1615 --------------------------
1618 new Hash_Tables.Generic_Bounded_Keys
1619 (HT_Types => HT_Types,
1621 Set_Next => Set_Next,
1622 Key_Type => Key_Type,
1624 Equivalent_Keys => Equivalent_Key_Node);
1632 Key : Key_Type) return Boolean
1635 return Find (Container, Key) /= No_Element;
1643 (Container : in out Set;
1650 Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1653 raise Constraint_Error with "attempt to delete key not in set";
1656 Free (Container, X);
1665 Key : Key_Type) return Element_Type
1667 Node : constant Count_Type := Find (Container, Key).Node;
1671 raise Constraint_Error with "key not in map";
1674 return Container.Nodes (Node).Element;
1677 -------------------------
1678 -- Equivalent_Key_Node --
1679 -------------------------
1681 function Equivalent_Key_Node
1683 Node : Node_Type) return Boolean
1686 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1687 end Equivalent_Key_Node;
1694 (Container : in out Set;
1699 Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1700 Free (Container, X);
1709 Key : Key_Type) return Cursor
1711 Node : constant Count_Type := Key_Keys.Find (Container, Key);
1713 return (if Node = 0 then No_Element else (Node => Node));
1720 function Key (Container : Set; Position : Cursor) return Key_Type is
1722 if not Has_Element (Container, Position) then
1723 raise Constraint_Error with
1724 "Position cursor has no element";
1728 (Vet (Container, Position), "bad cursor in function Key");
1731 N : Node_Type renames Container.Nodes (Position.Node);
1733 return Key (N.Element);
1742 (Container : in out Set;
1744 New_Item : Element_Type)
1746 Node : constant Count_Type := Key_Keys.Find (Container, Key);
1750 raise Constraint_Error with
1751 "attempt to replace key not in set";
1754 Replace_Element (Container, Node, New_Item);
1757 -----------------------------------
1758 -- Update_Element_Preserving_Key --
1759 -----------------------------------
1761 procedure Update_Element_Preserving_Key
1762 (Container : in out Set;
1764 Process : not null access
1765 procedure (Element : in out Element_Type))
1768 N : Nodes_Type renames Container.Nodes;
1772 if Position.Node = 0 then
1773 raise Constraint_Error with
1774 "Position cursor equals No_Element";
1778 (Vet (Container, Position),
1779 "bad cursor in Update_Element_Preserving_Key");
1781 -- Record bucket now, in case key is changed
1783 Indx := HT_Ops.Index (Container.Buckets, N (Position.Node));
1786 E : Element_Type renames N (Position.Node).Element;
1787 K : constant Key_Type := Key (E);
1788 B : Natural renames Container.Busy;
1789 L : Natural renames Container.Lock;
1807 if Equivalent_Keys (K, Key (E)) then
1808 pragma Assert (Hash (K) = Hash (E));
1813 -- Key was modified, so remove this node from set
1815 if Container.Buckets (Indx) = Position.Node then
1816 Container.Buckets (Indx) := N (Position.Node).Next;
1820 Prev : Count_Type := Container.Buckets (Indx);
1823 while N (Prev).Next /= Position.Node loop
1824 Prev := N (Prev).Next;
1827 raise Program_Error with
1828 "Position cursor is bad (node not found)";
1832 N (Prev).Next := N (Position.Node).Next;
1836 Container.Length := Container.Length - 1;
1837 Free (Container, Position.Node);
1839 raise Program_Error with "key was modified";
1840 end Update_Element_Preserving_Key;
1844 end Ada.Containers.Formal_Hashed_Sets;