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 _ O R D E R 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.Red_Black_Trees.Generic_Bounded_Operations;
32 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
34 with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
35 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
37 with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
39 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations);
41 with System; use type System.Address;
43 package body Ada.Containers.Bounded_Ordered_Sets is
45 ------------------------------
46 -- Access to Fields of Node --
47 ------------------------------
49 -- These subprograms provide functional notation for access to fields
50 -- of a node, and procedural notation for modifying these fields.
52 function Color (Node : Node_Type) return Red_Black_Trees.Color_Type;
53 pragma Inline (Color);
55 function Left (Node : Node_Type) return Count_Type;
58 function Parent (Node : Node_Type) return Count_Type;
59 pragma Inline (Parent);
61 function Right (Node : Node_Type) return Count_Type;
62 pragma Inline (Right);
65 (Node : in out Node_Type;
66 Color : Red_Black_Trees.Color_Type);
67 pragma Inline (Set_Color);
69 procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
70 pragma Inline (Set_Left);
72 procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
73 pragma Inline (Set_Right);
75 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
76 pragma Inline (Set_Parent);
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 procedure Insert_Sans_Hint
83 (Container : in out Set;
84 New_Item : Element_Type;
85 Node : out Count_Type;
86 Inserted : out Boolean);
88 procedure Insert_With_Hint
89 (Dst_Set : in out Set;
90 Dst_Hint : Count_Type;
92 Dst_Node : out Count_Type);
94 function Is_Greater_Element_Node
96 Right : Node_Type) return Boolean;
97 pragma Inline (Is_Greater_Element_Node);
99 function Is_Less_Element_Node
100 (Left : Element_Type;
101 Right : Node_Type) return Boolean;
102 pragma Inline (Is_Less_Element_Node);
104 function Is_Less_Node_Node (L, R : Node_Type) return Boolean;
105 pragma Inline (Is_Less_Node_Node);
107 procedure Replace_Element
108 (Container : in out Set;
110 Item : Element_Type);
112 --------------------------
113 -- Local Instantiations --
114 --------------------------
116 package Tree_Operations is
117 new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types);
121 package Element_Keys is
122 new Red_Black_Trees.Generic_Bounded_Keys
123 (Tree_Operations => Tree_Operations,
124 Key_Type => Element_Type,
125 Is_Less_Key_Node => Is_Less_Element_Node,
126 Is_Greater_Key_Node => Is_Greater_Element_Node);
129 new Red_Black_Trees.Generic_Bounded_Set_Operations
130 (Tree_Operations => Tree_Operations,
133 Insert_With_Hint => Insert_With_Hint,
134 Is_Less => Is_Less_Node_Node);
140 function "<" (Left, Right : Cursor) return Boolean is
142 if Left.Node = 0 then
143 raise Constraint_Error with "Left cursor equals No_Element";
146 if Right.Node = 0 then
147 raise Constraint_Error with "Right cursor equals No_Element";
150 pragma Assert (Vet (Left.Container.all, Left.Node),
151 "bad Left cursor in ""<""");
153 pragma Assert (Vet (Right.Container.all, Right.Node),
154 "bad Right cursor in ""<""");
157 LN : Nodes_Type renames Left.Container.Nodes;
158 RN : Nodes_Type renames Right.Container.Nodes;
160 return LN (Left.Node).Element < RN (Right.Node).Element;
164 function "<" (Left : Cursor; Right : Element_Type) return Boolean is
166 if Left.Node = 0 then
167 raise Constraint_Error with "Left cursor equals No_Element";
170 pragma Assert (Vet (Left.Container.all, Left.Node),
171 "bad Left cursor in ""<""");
173 return Left.Container.Nodes (Left.Node).Element < Right;
176 function "<" (Left : Element_Type; Right : Cursor) return Boolean is
178 if Right.Node = 0 then
179 raise Constraint_Error with "Right cursor equals No_Element";
182 pragma Assert (Vet (Right.Container.all, Right.Node),
183 "bad Right cursor in ""<""");
185 return Left < Right.Container.Nodes (Right.Node).Element;
192 function "=" (Left, Right : Set) return Boolean is
193 function Is_Equal_Node_Node (L, R : Node_Type) return Boolean;
194 pragma Inline (Is_Equal_Node_Node);
197 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
199 ------------------------
200 -- Is_Equal_Node_Node --
201 ------------------------
203 function Is_Equal_Node_Node (L, R : Node_Type) return Boolean is
205 return L.Element = R.Element;
206 end Is_Equal_Node_Node;
208 -- Start of processing for Is_Equal
211 return Is_Equal (Left, Right);
218 function ">" (Left, Right : Cursor) return Boolean is
220 if Left.Node = 0 then
221 raise Constraint_Error with "Left cursor equals No_Element";
224 if Right.Node = 0 then
225 raise Constraint_Error with "Right cursor equals No_Element";
228 pragma Assert (Vet (Left.Container.all, Left.Node),
229 "bad Left cursor in "">""");
231 pragma Assert (Vet (Right.Container.all, Right.Node),
232 "bad Right cursor in "">""");
234 -- L > R same as R < L
237 LN : Nodes_Type renames Left.Container.Nodes;
238 RN : Nodes_Type renames Right.Container.Nodes;
240 return RN (Right.Node).Element < LN (Left.Node).Element;
244 function ">" (Left : Element_Type; Right : Cursor) return Boolean is
246 if Right.Node = 0 then
247 raise Constraint_Error with "Right cursor equals No_Element";
250 pragma Assert (Vet (Right.Container.all, Right.Node),
251 "bad Right cursor in "">""");
253 return Right.Container.Nodes (Right.Node).Element < Left;
256 function ">" (Left : Cursor; Right : Element_Type) return Boolean is
258 if Left.Node = 0 then
259 raise Constraint_Error with "Left cursor equals No_Element";
262 pragma Assert (Vet (Left.Container.all, Left.Node),
263 "bad Left cursor in "">""");
265 return Right < Left.Container.Nodes (Left.Node).Element;
272 procedure Assign (Target : in out Set; Source : Set) is
273 procedure Append_Element (Source_Node : Count_Type);
275 procedure Append_Elements is
276 new Tree_Operations.Generic_Iteration (Append_Element);
282 procedure Append_Element (Source_Node : Count_Type) is
283 SN : Node_Type renames Source.Nodes (Source_Node);
285 procedure Set_Element (Node : in out Node_Type);
286 pragma Inline (Set_Element);
288 function New_Node return Count_Type;
289 pragma Inline (New_Node);
291 procedure Insert_Post is
292 new Element_Keys.Generic_Insert_Post (New_Node);
294 procedure Unconditional_Insert_Sans_Hint is
295 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
297 procedure Unconditional_Insert_Avec_Hint is
298 new Element_Keys.Generic_Unconditional_Insert_With_Hint
300 Unconditional_Insert_Sans_Hint);
302 procedure Allocate is
303 new Tree_Operations.Generic_Allocate (Set_Element);
309 function New_Node return Count_Type is
313 Allocate (Target, Result);
321 procedure Set_Element (Node : in out Node_Type) is
323 Node.Element := SN.Element;
326 Target_Node : Count_Type;
328 -- Start of processing for Append_Element
331 Unconditional_Insert_Avec_Hint
335 Node => Target_Node);
338 -- Start of processing for Assign
341 if Target'Address = Source'Address then
345 if Target.Capacity < Source.Length then
347 with "Target capacity is less than Source length";
351 Append_Elements (Source);
358 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
359 Node : constant Count_Type :=
360 Element_Keys.Ceiling (Container, Item);
367 return Cursor'(Container'Unrestricted_Access, Node);
374 procedure Clear (Container : in out Set) is
376 Tree_Operations.Clear_Tree (Container);
383 function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is
394 Item : Element_Type) return Boolean
397 return Find (Container, Item) /= No_Element;
404 function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
411 elsif Capacity >= Source.Length then
415 raise Capacity_Error with "Capacity value too small";
418 return Target : Set (Capacity => C) do
419 Assign (Target => Target, Source => Source);
427 procedure Delete (Container : in out Set; Position : in out Cursor) is
429 if Position.Node = 0 then
430 raise Constraint_Error with "Position cursor equals No_Element";
433 if Position.Container /= Container'Unrestricted_Access then
434 raise Program_Error with "Position cursor designates wrong set";
437 pragma Assert (Vet (Container, Position.Node),
438 "bad cursor in Delete");
440 Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
441 Tree_Operations.Free (Container, Position.Node);
443 Position := No_Element;
446 procedure Delete (Container : in out Set; Item : Element_Type) is
447 X : constant Count_Type := Element_Keys.Find (Container, Item);
451 raise Constraint_Error with "attempt to delete element not in set";
454 Tree_Operations.Delete_Node_Sans_Free (Container, X);
455 Tree_Operations.Free (Container, X);
462 procedure Delete_First (Container : in out Set) is
463 X : constant Count_Type := Container.First;
467 Tree_Operations.Delete_Node_Sans_Free (Container, X);
468 Tree_Operations.Free (Container, X);
476 procedure Delete_Last (Container : in out Set) is
477 X : constant Count_Type := Container.Last;
481 Tree_Operations.Delete_Node_Sans_Free (Container, X);
482 Tree_Operations.Free (Container, X);
490 procedure Difference (Target : in out Set; Source : Set)
491 renames Set_Ops.Set_Difference;
493 function Difference (Left, Right : Set) return Set
494 renames Set_Ops.Set_Difference;
500 function Element (Position : Cursor) return Element_Type is
502 if Position.Node = 0 then
503 raise Constraint_Error with "Position cursor equals No_Element";
506 pragma Assert (Vet (Position.Container.all, Position.Node),
507 "bad cursor in Element");
509 return Position.Container.Nodes (Position.Node).Element;
512 -------------------------
513 -- Equivalent_Elements --
514 -------------------------
516 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
525 end Equivalent_Elements;
527 ---------------------
528 -- Equivalent_Sets --
529 ---------------------
531 function Equivalent_Sets (Left, Right : Set) return Boolean is
532 function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean;
533 pragma Inline (Is_Equivalent_Node_Node);
535 function Is_Equivalent is
536 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
538 -----------------------------
539 -- Is_Equivalent_Node_Node --
540 -----------------------------
542 function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is
544 if L.Element < R.Element then
546 elsif R.Element < L.Element then
551 end Is_Equivalent_Node_Node;
553 -- Start of processing for Equivalent_Sets
556 return Is_Equivalent (Left, Right);
563 procedure Exclude (Container : in out Set; Item : Element_Type) is
564 X : constant Count_Type := Element_Keys.Find (Container, Item);
568 Tree_Operations.Delete_Node_Sans_Free (Container, X);
569 Tree_Operations.Free (Container, X);
577 function Find (Container : Set; Item : Element_Type) return Cursor is
578 Node : constant Count_Type := Element_Keys.Find (Container, Item);
585 return Cursor'(Container'Unrestricted_Access, Node);
592 function First (Container : Set) return Cursor is
594 if Container.First = 0 then
598 return Cursor'(Container'Unrestricted_Access, Container.First);
605 function First_Element (Container : Set) return Element_Type is
607 if Container.First = 0 then
608 raise Constraint_Error with "set is empty";
611 return Container.Nodes (Container.First).Element;
618 function Floor (Container : Set; Item : Element_Type) return Cursor is
619 Node : constant Count_Type := Element_Keys.Floor (Container, Item);
626 return Cursor'(Container'Unrestricted_Access, Node);
633 package body Generic_Keys is
635 -----------------------
636 -- Local Subprograms --
637 -----------------------
639 function Is_Greater_Key_Node
641 Right : Node_Type) return Boolean;
642 pragma Inline (Is_Greater_Key_Node);
644 function Is_Less_Key_Node
646 Right : Node_Type) return Boolean;
647 pragma Inline (Is_Less_Key_Node);
649 --------------------------
650 -- Local Instantiations --
651 --------------------------
654 new Red_Black_Trees.Generic_Bounded_Keys
655 (Tree_Operations => Tree_Operations,
656 Key_Type => Key_Type,
657 Is_Less_Key_Node => Is_Less_Key_Node,
658 Is_Greater_Key_Node => Is_Greater_Key_Node);
664 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
665 Node : constant Count_Type :=
666 Key_Keys.Ceiling (Container, Key);
673 return Cursor'(Container'Unrestricted_Access, Node);
680 function Contains (Container : Set; Key : Key_Type) return Boolean is
682 return Find (Container, Key) /= No_Element;
689 procedure Delete (Container : in out Set; Key : Key_Type) is
690 X : constant Count_Type := Key_Keys.Find (Container, Key);
694 raise Constraint_Error with "attempt to delete key not in set";
697 Tree_Operations.Delete_Node_Sans_Free (Container, X);
698 Tree_Operations.Free (Container, X);
705 function Element (Container : Set; Key : Key_Type) return Element_Type is
706 Node : constant Count_Type := Key_Keys.Find (Container, Key);
710 raise Constraint_Error with "key not in set";
713 return Container.Nodes (Node).Element;
716 ---------------------
717 -- Equivalent_Keys --
718 ---------------------
720 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
735 procedure Exclude (Container : in out Set; Key : Key_Type) is
736 X : constant Count_Type := Key_Keys.Find (Container, Key);
740 Tree_Operations.Delete_Node_Sans_Free (Container, X);
741 Tree_Operations.Free (Container, X);
749 function Find (Container : Set; Key : Key_Type) return Cursor is
750 Node : constant Count_Type := Key_Keys.Find (Container, Key);
757 return Cursor'(Container'Unrestricted_Access, Node);
764 function Floor (Container : Set; Key : Key_Type) return Cursor is
765 Node : constant Count_Type := Key_Keys.Floor (Container, Key);
772 return Cursor'(Container'Unrestricted_Access, Node);
775 -------------------------
776 -- Is_Greater_Key_Node --
777 -------------------------
779 function Is_Greater_Key_Node
781 Right : Node_Type) return Boolean
784 return Key (Right.Element) < Left;
785 end Is_Greater_Key_Node;
787 ----------------------
788 -- Is_Less_Key_Node --
789 ----------------------
791 function Is_Less_Key_Node
793 Right : Node_Type) return Boolean
796 return Left < Key (Right.Element);
797 end Is_Less_Key_Node;
803 function Key (Position : Cursor) return Key_Type is
805 if Position.Node = 0 then
806 raise Constraint_Error with
807 "Position cursor equals No_Element";
810 pragma Assert (Vet (Position.Container.all, Position.Node),
811 "bad cursor in Key");
813 return Key (Position.Container.Nodes (Position.Node).Element);
821 (Container : in out Set;
823 New_Item : Element_Type)
825 Node : constant Count_Type := Key_Keys.Find (Container, Key);
829 raise Constraint_Error with
830 "attempt to replace key not in set";
833 Replace_Element (Container, Node, New_Item);
836 -----------------------------------
837 -- Update_Element_Preserving_Key --
838 -----------------------------------
840 procedure Update_Element_Preserving_Key
841 (Container : in out Set;
843 Process : not null access procedure (Element : in out Element_Type))
846 if Position.Node = 0 then
847 raise Constraint_Error with
848 "Position cursor equals No_Element";
851 if Position.Container /= Container'Unrestricted_Access then
852 raise Program_Error with
853 "Position cursor designates wrong set";
856 pragma Assert (Vet (Container, Position.Node),
857 "bad cursor in Update_Element_Preserving_Key");
860 N : Node_Type renames Container.Nodes (Position.Node);
861 E : Element_Type renames N.Element;
862 K : constant Key_Type := Key (E);
864 B : Natural renames Container.Busy;
865 L : Natural renames Container.Lock;
883 if Equivalent_Keys (K, Key (E)) then
888 Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
889 Tree_Operations.Free (Container, Position.Node);
891 raise Program_Error with "key was modified";
892 end Update_Element_Preserving_Key;
900 function Has_Element (Position : Cursor) return Boolean is
902 return Position /= No_Element;
909 procedure Include (Container : in out Set; New_Item : Element_Type) is
914 Insert (Container, New_Item, Position, Inserted);
917 if Container.Lock > 0 then
918 raise Program_Error with
919 "attempt to tamper with elements (set is locked)";
922 Container.Nodes (Position.Node).Element := New_Item;
931 (Container : in out Set;
932 New_Item : Element_Type;
933 Position : out Cursor;
934 Inserted : out Boolean)
943 Position.Container := Container'Unrestricted_Access;
947 (Container : in out Set;
948 New_Item : Element_Type)
951 pragma Unreferenced (Position);
956 Insert (Container, New_Item, Position, Inserted);
959 raise Constraint_Error with
960 "attempt to insert element already in set";
964 ----------------------
965 -- Insert_Sans_Hint --
966 ----------------------
968 procedure Insert_Sans_Hint
969 (Container : in out Set;
970 New_Item : Element_Type;
971 Node : out Count_Type;
972 Inserted : out Boolean)
974 procedure Set_Element (Node : in out Node_Type);
975 pragma Inline (Set_Element);
977 function New_Node return Count_Type;
978 pragma Inline (New_Node);
980 procedure Insert_Post is
981 new Element_Keys.Generic_Insert_Post (New_Node);
983 procedure Conditional_Insert_Sans_Hint is
984 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
986 procedure Allocate is
987 new Tree_Operations.Generic_Allocate (Set_Element);
993 function New_Node return Count_Type is
997 Allocate (Container, Result);
1005 procedure Set_Element (Node : in out Node_Type) is
1007 Node.Element := New_Item;
1010 -- Start of processing for Insert_Sans_Hint
1013 Conditional_Insert_Sans_Hint
1018 end Insert_Sans_Hint;
1020 ----------------------
1021 -- Insert_With_Hint --
1022 ----------------------
1024 procedure Insert_With_Hint
1025 (Dst_Set : in out Set;
1026 Dst_Hint : Count_Type;
1027 Src_Node : Node_Type;
1028 Dst_Node : out Count_Type)
1031 pragma Unreferenced (Success);
1033 procedure Set_Element (Node : in out Node_Type);
1034 pragma Inline (Set_Element);
1036 function New_Node return Count_Type;
1037 pragma Inline (New_Node);
1039 procedure Insert_Post is
1040 new Element_Keys.Generic_Insert_Post (New_Node);
1042 procedure Insert_Sans_Hint is
1043 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1045 procedure Local_Insert_With_Hint is
1046 new Element_Keys.Generic_Conditional_Insert_With_Hint
1050 procedure Allocate is
1051 new Tree_Operations.Generic_Allocate (Set_Element);
1057 function New_Node return Count_Type is
1058 Result : Count_Type;
1061 Allocate (Dst_Set, Result);
1069 procedure Set_Element (Node : in out Node_Type) is
1071 Node.Element := Src_Node.Element;
1074 -- Start of processing for Insert_With_Hint
1077 Local_Insert_With_Hint
1083 end Insert_With_Hint;
1089 procedure Intersection (Target : in out Set; Source : Set)
1090 renames Set_Ops.Set_Intersection;
1092 function Intersection (Left, Right : Set) return Set
1093 renames Set_Ops.Set_Intersection;
1099 function Is_Empty (Container : Set) return Boolean is
1101 return Container.Length = 0;
1104 -----------------------------
1105 -- Is_Greater_Element_Node --
1106 -----------------------------
1108 function Is_Greater_Element_Node
1109 (Left : Element_Type;
1110 Right : Node_Type) return Boolean
1113 -- Compute e > node same as node < e
1115 return Right.Element < Left;
1116 end Is_Greater_Element_Node;
1118 --------------------------
1119 -- Is_Less_Element_Node --
1120 --------------------------
1122 function Is_Less_Element_Node
1123 (Left : Element_Type;
1124 Right : Node_Type) return Boolean
1127 return Left < Right.Element;
1128 end Is_Less_Element_Node;
1130 -----------------------
1131 -- Is_Less_Node_Node --
1132 -----------------------
1134 function Is_Less_Node_Node (L, R : Node_Type) return Boolean is
1136 return L.Element < R.Element;
1137 end Is_Less_Node_Node;
1143 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean
1144 renames Set_Ops.Set_Subset;
1152 Process : not null access procedure (Position : Cursor))
1154 procedure Process_Node (Node : Count_Type);
1155 pragma Inline (Process_Node);
1157 procedure Local_Iterate is
1158 new Tree_Operations.Generic_Iteration (Process_Node);
1164 procedure Process_Node (Node : Count_Type) is
1166 Process (Cursor'(Container'Unrestricted_Access, Node));
1169 S : Set renames Container'Unrestricted_Access.all;
1170 B : Natural renames S.Busy;
1172 -- Start of processing for Iterate
1192 function Last (Container : Set) return Cursor is
1194 if Container.Last = 0 then
1198 return Cursor'(Container'Unrestricted_Access, Container.Last);
1205 function Last_Element (Container : Set) return Element_Type is
1207 if Container.Last = 0 then
1208 raise Constraint_Error with "set is empty";
1211 return Container.Nodes (Container.Last).Element;
1218 function Left (Node : Node_Type) return Count_Type is
1227 function Length (Container : Set) return Count_Type is
1229 return Container.Length;
1236 procedure Move (Target : in out Set; Source : in out Set) is
1238 if Target'Address = Source'Address then
1242 if Source.Busy > 0 then
1243 raise Program_Error with
1244 "attempt to tamper with cursors (container is busy)";
1247 Target.Assign (Source);
1255 function Next (Position : Cursor) return Cursor is
1257 if Position = No_Element then
1261 pragma Assert (Vet (Position.Container.all, Position.Node),
1262 "bad cursor in Next");
1265 Node : constant Count_Type :=
1266 Tree_Operations.Next (Position.Container.all, Position.Node);
1273 return Cursor'(Position.Container, Node);
1277 procedure Next (Position : in out Cursor) is
1279 Position := Next (Position);
1286 function Overlap (Left, Right : Set) return Boolean
1287 renames Set_Ops.Set_Overlap;
1293 function Parent (Node : Node_Type) return Count_Type is
1302 function Previous (Position : Cursor) return Cursor is
1304 if Position = No_Element then
1308 pragma Assert (Vet (Position.Container.all, Position.Node),
1309 "bad cursor in Previous");
1312 Node : constant Count_Type :=
1313 Tree_Operations.Previous
1314 (Position.Container.all,
1322 return Cursor'(Position.Container, Node);
1326 procedure Previous (Position : in out Cursor) is
1328 Position := Previous (Position);
1335 procedure Query_Element
1337 Process : not null access procedure (Element : Element_Type))
1340 if Position.Node = 0 then
1341 raise Constraint_Error with "Position cursor equals No_Element";
1344 pragma Assert (Vet (Position.Container.all, Position.Node),
1345 "bad cursor in Query_Element");
1348 S : Set renames Position.Container.all;
1350 B : Natural renames S.Busy;
1351 L : Natural renames S.Lock;
1358 Process (S.Nodes (Position.Node).Element);
1376 (Stream : not null access Root_Stream_Type'Class;
1377 Container : out Set)
1379 procedure Read_Element (Node : in out Node_Type);
1380 pragma Inline (Read_Element);
1382 procedure Allocate is
1383 new Tree_Operations.Generic_Allocate (Read_Element);
1385 procedure Read_Elements is
1386 new Tree_Operations.Generic_Read (Allocate);
1392 procedure Read_Element (Node : in out Node_Type) is
1394 Element_Type'Read (Stream, Node.Element);
1397 -- Start of processing for Read
1400 Read_Elements (Stream, Container);
1404 (Stream : not null access Root_Stream_Type'Class;
1408 raise Program_Error with "attempt to stream set cursor";
1415 procedure Replace (Container : in out Set; New_Item : Element_Type) is
1416 Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
1420 raise Constraint_Error with
1421 "attempt to replace element not in set";
1424 if Container.Lock > 0 then
1425 raise Program_Error with
1426 "attempt to tamper with elements (set is locked)";
1429 Container.Nodes (Node).Element := New_Item;
1432 ---------------------
1433 -- Replace_Element --
1434 ---------------------
1436 procedure Replace_Element
1437 (Container : in out Set;
1439 Item : Element_Type)
1441 pragma Assert (Index /= 0);
1443 function New_Node return Count_Type;
1444 pragma Inline (New_Node);
1446 procedure Local_Insert_Post is
1447 new Element_Keys.Generic_Insert_Post (New_Node);
1449 procedure Local_Insert_Sans_Hint is
1450 new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
1452 procedure Local_Insert_With_Hint is
1453 new Element_Keys.Generic_Conditional_Insert_With_Hint
1455 Local_Insert_Sans_Hint);
1457 Nodes : Nodes_Type renames Container.Nodes;
1458 Node : Node_Type renames Nodes (Index);
1464 function New_Node return Count_Type is
1466 Node.Element := Item;
1467 Node.Color := Red_Black_Trees.Red;
1476 Result : Count_Type;
1479 -- Start of processing for Replace_Element
1482 if Item < Node.Element
1483 or else Node.Element < Item
1488 if Container.Lock > 0 then
1489 raise Program_Error with
1490 "attempt to tamper with elements (set is locked)";
1493 Node.Element := Item;
1497 Hint := Element_Keys.Ceiling (Container, Item);
1502 elsif Item < Nodes (Hint).Element then
1503 if Hint = Index then
1504 if Container.Lock > 0 then
1505 raise Program_Error with
1506 "attempt to tamper with elements (set is locked)";
1509 Node.Element := Item;
1514 pragma Assert (not (Nodes (Hint).Element < Item));
1515 raise Program_Error with "attempt to replace existing element";
1518 Tree_Operations.Delete_Node_Sans_Free (Container, Index);
1520 Local_Insert_With_Hint
1525 Inserted => Inserted);
1527 pragma Assert (Inserted);
1528 pragma Assert (Result = Index);
1529 end Replace_Element;
1531 procedure Replace_Element
1532 (Container : in out Set;
1534 New_Item : Element_Type)
1537 if Position.Node = 0 then
1538 raise Constraint_Error with
1539 "Position cursor equals No_Element";
1542 if Position.Container /= Container'Unrestricted_Access then
1543 raise Program_Error with
1544 "Position cursor designates wrong set";
1547 pragma Assert (Vet (Container, Position.Node),
1548 "bad cursor in Replace_Element");
1550 Replace_Element (Container, Position.Node, New_Item);
1551 end Replace_Element;
1553 ---------------------
1554 -- Reverse_Iterate --
1555 ---------------------
1557 procedure Reverse_Iterate
1559 Process : not null access procedure (Position : Cursor))
1561 procedure Process_Node (Node : Count_Type);
1562 pragma Inline (Process_Node);
1564 procedure Local_Reverse_Iterate is
1565 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1571 procedure Process_Node (Node : Count_Type) is
1573 Process (Cursor'(Container'Unrestricted_Access, Node));
1576 S : Set renames Container'Unrestricted_Access.all;
1577 B : Natural renames S.Busy;
1579 -- Start of processing for Reverse_Iterate
1585 Local_Reverse_Iterate (S);
1593 end Reverse_Iterate;
1599 function Right (Node : Node_Type) return Count_Type is
1609 (Node : in out Node_Type;
1610 Color : Red_Black_Trees.Color_Type)
1613 Node.Color := Color;
1620 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
1629 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
1631 Node.Parent := Parent;
1638 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
1640 Node.Right := Right;
1643 --------------------------
1644 -- Symmetric_Difference --
1645 --------------------------
1647 procedure Symmetric_Difference (Target : in out Set; Source : Set)
1648 renames Set_Ops.Set_Symmetric_Difference;
1650 function Symmetric_Difference (Left, Right : Set) return Set
1651 renames Set_Ops.Set_Symmetric_Difference;
1657 function To_Set (New_Item : Element_Type) return Set is
1661 return S : Set (1) do
1662 Insert_Sans_Hint (S, New_Item, Node, Inserted);
1663 pragma Assert (Inserted);
1671 procedure Union (Target : in out Set; Source : Set)
1672 renames Set_Ops.Set_Union;
1674 function Union (Left, Right : Set) return Set
1675 renames Set_Ops.Set_Union;
1682 (Stream : not null access Root_Stream_Type'Class;
1685 procedure Write_Element
1686 (Stream : not null access Root_Stream_Type'Class;
1688 pragma Inline (Write_Element);
1690 procedure Write_Elements is
1691 new Tree_Operations.Generic_Write (Write_Element);
1697 procedure Write_Element
1698 (Stream : not null access Root_Stream_Type'Class;
1702 Element_Type'Write (Stream, Node.Element);
1705 -- Start of processing for Write
1708 Write_Elements (Stream, Container);
1712 (Stream : not null access Root_Stream_Type'Class;
1716 raise Program_Error with "attempt to stream set cursor";
1719 end Ada.Containers.Bounded_Ordered_Sets;