1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . O R D E R E D _ S E T S --
9 -- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the contents of the part following the private keyword. --
15 -- GNAT is free software; you can redistribute it and/or modify it under --
16 -- terms of the GNU General Public License as published by the Free Soft- --
17 -- ware Foundation; either version 2, or (at your option) any later ver- --
18 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
21 -- for more details. You should have received a copy of the GNU General --
22 -- Public License distributed with GNAT; see file COPYING. If not, write --
23 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
24 -- Boston, MA 02110-1301, USA. --
26 -- As a special exception, if other files instantiate generics from this --
27 -- unit, or you link this unit with other files to produce an executable, --
28 -- this unit does not by itself cause the resulting executable to be --
29 -- covered by the GNU General Public License. This exception does not --
30 -- however invalidate any other reasons why the executable file might be --
31 -- covered by the GNU Public License. --
33 -- This unit was originally developed by Matthew J Heaney. --
34 ------------------------------------------------------------------------------
36 with Ada.Unchecked_Deallocation;
38 with Ada.Containers.Red_Black_Trees.Generic_Operations;
39 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
41 with Ada.Containers.Red_Black_Trees.Generic_Keys;
42 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
44 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
45 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
47 package body Ada.Containers.Ordered_Sets is
49 ------------------------------
50 -- Access to Fields of Node --
51 ------------------------------
53 -- These subprograms provide functional notation for access to fields
54 -- of a node, and procedural notation for modifiying these fields.
56 function Color (Node : Node_Access) return Color_Type;
57 pragma Inline (Color);
59 function Left (Node : Node_Access) return Node_Access;
62 function Parent (Node : Node_Access) return Node_Access;
63 pragma Inline (Parent);
65 function Right (Node : Node_Access) return Node_Access;
66 pragma Inline (Right);
68 procedure Set_Color (Node : Node_Access; Color : Color_Type);
69 pragma Inline (Set_Color);
71 procedure Set_Left (Node : Node_Access; Left : Node_Access);
72 pragma Inline (Set_Left);
74 procedure Set_Right (Node : Node_Access; Right : Node_Access);
75 pragma Inline (Set_Right);
77 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
78 pragma Inline (Set_Parent);
80 -----------------------
81 -- Local Subprograms --
82 -----------------------
84 function Copy_Node (Source : Node_Access) return Node_Access;
85 pragma Inline (Copy_Node);
87 procedure Free (X : in out Node_Access);
89 procedure Insert_Sans_Hint
90 (Tree : in out Tree_Type;
91 New_Item : Element_Type;
92 Node : out Node_Access;
93 Inserted : out Boolean);
95 procedure Insert_With_Hint
96 (Dst_Tree : in out Tree_Type;
97 Dst_Hint : Node_Access;
98 Src_Node : Node_Access;
99 Dst_Node : out Node_Access);
101 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
102 pragma Inline (Is_Equal_Node_Node);
104 function Is_Greater_Element_Node
105 (Left : Element_Type;
106 Right : Node_Access) return Boolean;
107 pragma Inline (Is_Greater_Element_Node);
109 function Is_Less_Element_Node
110 (Left : Element_Type;
111 Right : Node_Access) return Boolean;
112 pragma Inline (Is_Less_Element_Node);
114 function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
115 pragma Inline (Is_Less_Node_Node);
117 procedure Replace_Element
118 (Tree : in out Tree_Type;
120 Item : Element_Type);
122 --------------------------
123 -- Local Instantiations --
124 --------------------------
126 package Tree_Operations is
127 new Red_Black_Trees.Generic_Operations (Tree_Types);
129 procedure Delete_Tree is
130 new Tree_Operations.Generic_Delete_Tree (Free);
132 function Copy_Tree is
133 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
138 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
140 package Element_Keys is
141 new Red_Black_Trees.Generic_Keys
142 (Tree_Operations => Tree_Operations,
143 Key_Type => Element_Type,
144 Is_Less_Key_Node => Is_Less_Element_Node,
145 Is_Greater_Key_Node => Is_Greater_Element_Node);
148 new Generic_Set_Operations
149 (Tree_Operations => Tree_Operations,
150 Insert_With_Hint => Insert_With_Hint,
151 Copy_Tree => Copy_Tree,
152 Delete_Tree => Delete_Tree,
153 Is_Less => Is_Less_Node_Node,
160 function "<" (Left, Right : Cursor) return Boolean is
162 if Left.Node = null then
163 raise Constraint_Error with "Left cursor equals No_Element";
166 if Right.Node = null then
167 raise Constraint_Error with "Right cursor equals No_Element";
170 pragma Assert (Vet (Left.Container.Tree, Left.Node),
171 "bad Left cursor in ""<""");
173 pragma Assert (Vet (Right.Container.Tree, Right.Node),
174 "bad Right cursor in ""<""");
176 return Left.Node.Element < Right.Node.Element;
179 function "<" (Left : Cursor; Right : Element_Type) return Boolean is
181 if Left.Node = null then
182 raise Constraint_Error with "Left cursor equals No_Element";
185 pragma Assert (Vet (Left.Container.Tree, Left.Node),
186 "bad Left cursor in ""<""");
188 return Left.Node.Element < Right;
191 function "<" (Left : Element_Type; Right : Cursor) return Boolean is
193 if Right.Node = null then
194 raise Constraint_Error with "Right cursor equals No_Element";
197 pragma Assert (Vet (Right.Container.Tree, Right.Node),
198 "bad Right cursor in ""<""");
200 return Left < Right.Node.Element;
207 function "=" (Left, Right : Set) return Boolean is
209 return Is_Equal (Left.Tree, Right.Tree);
216 function ">" (Left, Right : Cursor) return Boolean is
218 if Left.Node = null then
219 raise Constraint_Error with "Left cursor equals No_Element";
222 if Right.Node = null then
223 raise Constraint_Error with "Right cursor equals No_Element";
226 pragma Assert (Vet (Left.Container.Tree, Left.Node),
227 "bad Left cursor in "">""");
229 pragma Assert (Vet (Right.Container.Tree, Right.Node),
230 "bad Right cursor in "">""");
232 -- L > R same as R < L
234 return Right.Node.Element < Left.Node.Element;
237 function ">" (Left : Element_Type; Right : Cursor) return Boolean is
239 if Right.Node = null then
240 raise Constraint_Error with "Right cursor equals No_Element";
243 pragma Assert (Vet (Right.Container.Tree, Right.Node),
244 "bad Right cursor in "">""");
246 return Right.Node.Element < Left;
249 function ">" (Left : Cursor; Right : Element_Type) return Boolean is
251 if Left.Node = null then
252 raise Constraint_Error with "Left cursor equals No_Element";
255 pragma Assert (Vet (Left.Container.Tree, Left.Node),
256 "bad Left cursor in "">""");
258 return Right < Left.Node.Element;
266 new Tree_Operations.Generic_Adjust (Copy_Tree);
268 procedure Adjust (Container : in out Set) is
270 Adjust (Container.Tree);
277 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
278 Node : constant Node_Access :=
279 Element_Keys.Ceiling (Container.Tree, Item);
286 return Cursor'(Container'Unrestricted_Access, Node);
294 new Tree_Operations.Generic_Clear (Delete_Tree);
296 procedure Clear (Container : in out Set) is
298 Clear (Container.Tree);
305 function Color (Node : Node_Access) return Color_Type is
316 Item : Element_Type) return Boolean
319 return Find (Container, Item) /= No_Element;
326 function Copy_Node (Source : Node_Access) return Node_Access is
327 Target : constant Node_Access :=
328 new Node_Type'(Parent => null,
331 Color => Source.Color,
332 Element => Source.Element);
341 procedure Delete (Container : in out Set; Position : in out Cursor) is
343 if Position.Node = null then
344 raise Constraint_Error with "Position cursor equals No_Element";
347 if Position.Container /= Container'Unrestricted_Access then
348 raise Program_Error with "Position cursor designates wrong set";
351 pragma Assert (Vet (Container.Tree, Position.Node),
352 "bad cursor in Delete");
354 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
355 Free (Position.Node);
356 Position.Container := null;
359 procedure Delete (Container : in out Set; Item : Element_Type) is
360 X : Node_Access := Element_Keys.Find (Container.Tree, Item);
364 raise Constraint_Error with "attempt to delete element not in set";
367 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
375 procedure Delete_First (Container : in out Set) is
376 Tree : Tree_Type renames Container.Tree;
377 X : Node_Access := Tree.First;
381 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
390 procedure Delete_Last (Container : in out Set) is
391 Tree : Tree_Type renames Container.Tree;
392 X : Node_Access := Tree.Last;
396 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
405 procedure Difference (Target : in out Set; Source : Set) is
407 Set_Ops.Difference (Target.Tree, Source.Tree);
410 function Difference (Left, Right : Set) return Set is
411 Tree : constant Tree_Type :=
412 Set_Ops.Difference (Left.Tree, Right.Tree);
414 return Set'(Controlled with Tree);
421 function Element (Position : Cursor) return Element_Type is
423 if Position.Node = null then
424 raise Constraint_Error with "Position cursor equals No_Element";
427 pragma Assert (Vet (Position.Container.Tree, Position.Node),
428 "bad cursor in Element");
430 return Position.Node.Element;
433 -------------------------
434 -- Equivalent_Elements --
435 -------------------------
437 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
446 end Equivalent_Elements;
448 ---------------------
449 -- Equivalent_Sets --
450 ---------------------
452 function Equivalent_Sets (Left, Right : Set) return Boolean is
453 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
454 pragma Inline (Is_Equivalent_Node_Node);
456 function Is_Equivalent is
457 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
459 -----------------------------
460 -- Is_Equivalent_Node_Node --
461 -----------------------------
463 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
465 if L.Element < R.Element then
467 elsif R.Element < L.Element then
472 end Is_Equivalent_Node_Node;
474 -- Start of processing for Equivalent_Sets
477 return Is_Equivalent (Left.Tree, Right.Tree);
484 procedure Exclude (Container : in out Set; Item : Element_Type) is
485 X : Node_Access := Element_Keys.Find (Container.Tree, Item);
489 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
498 function Find (Container : Set; Item : Element_Type) return Cursor is
499 Node : constant Node_Access :=
500 Element_Keys.Find (Container.Tree, Item);
507 return Cursor'(Container'Unrestricted_Access, Node);
514 function First (Container : Set) return Cursor is
516 if Container.Tree.First = null then
520 return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
527 function First_Element (Container : Set) return Element_Type is
529 if Container.Tree.First = null then
530 raise Constraint_Error with "set is empty";
533 return Container.Tree.First.Element;
540 function Floor (Container : Set; Item : Element_Type) return Cursor is
541 Node : constant Node_Access :=
542 Element_Keys.Floor (Container.Tree, Item);
549 return Cursor'(Container'Unrestricted_Access, Node);
556 procedure Free (X : in out Node_Access) is
557 procedure Deallocate is
558 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
574 package body Generic_Keys is
576 -----------------------
577 -- Local Subprograms --
578 -----------------------
580 function Is_Greater_Key_Node
582 Right : Node_Access) return Boolean;
583 pragma Inline (Is_Greater_Key_Node);
585 function Is_Less_Key_Node
587 Right : Node_Access) return Boolean;
588 pragma Inline (Is_Less_Key_Node);
590 --------------------------
591 -- Local Instantiations --
592 --------------------------
595 new Red_Black_Trees.Generic_Keys
596 (Tree_Operations => Tree_Operations,
597 Key_Type => Key_Type,
598 Is_Less_Key_Node => Is_Less_Key_Node,
599 Is_Greater_Key_Node => Is_Greater_Key_Node);
605 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
606 Node : constant Node_Access :=
607 Key_Keys.Ceiling (Container.Tree, Key);
614 return Cursor'(Container'Unrestricted_Access, Node);
621 function Contains (Container : Set; Key : Key_Type) return Boolean is
623 return Find (Container, Key) /= No_Element;
630 procedure Delete (Container : in out Set; Key : Key_Type) is
631 X : Node_Access := Key_Keys.Find (Container.Tree, Key);
635 raise Constraint_Error with "attempt to delete key not in set";
638 Delete_Node_Sans_Free (Container.Tree, X);
646 function Element (Container : Set; Key : Key_Type) return Element_Type is
647 Node : constant Node_Access :=
648 Key_Keys.Find (Container.Tree, Key);
652 raise Constraint_Error with "key not in set";
658 ---------------------
659 -- Equivalent_Keys --
660 ---------------------
662 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
677 procedure Exclude (Container : in out Set; Key : Key_Type) is
678 X : Node_Access := Key_Keys.Find (Container.Tree, Key);
682 Delete_Node_Sans_Free (Container.Tree, X);
691 function Find (Container : Set; Key : Key_Type) return Cursor is
692 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
699 return Cursor'(Container'Unrestricted_Access, Node);
706 function Floor (Container : Set; Key : Key_Type) return Cursor is
707 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
714 return Cursor'(Container'Unrestricted_Access, Node);
717 -------------------------
718 -- Is_Greater_Key_Node --
719 -------------------------
721 function Is_Greater_Key_Node
723 Right : Node_Access) return Boolean
726 return Key (Right.Element) < Left;
727 end Is_Greater_Key_Node;
729 ----------------------
730 -- Is_Less_Key_Node --
731 ----------------------
733 function Is_Less_Key_Node
735 Right : Node_Access) return Boolean
738 return Left < Key (Right.Element);
739 end Is_Less_Key_Node;
745 function Key (Position : Cursor) return Key_Type is
747 if Position.Node = null then
748 raise Constraint_Error with
749 "Position cursor equals No_Element";
752 pragma Assert (Vet (Position.Container.Tree, Position.Node),
753 "bad cursor in Key");
755 return Key (Position.Node.Element);
763 (Container : in out Set;
765 New_Item : Element_Type)
767 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
771 raise Constraint_Error with
772 "attempt to replace key not in set";
775 Replace_Element (Container.Tree, Node, New_Item);
778 -----------------------------------
779 -- Update_Element_Preserving_Key --
780 -----------------------------------
782 procedure Update_Element_Preserving_Key
783 (Container : in out Set;
785 Process : not null access procedure (Element : in out Element_Type))
787 Tree : Tree_Type renames Container.Tree;
790 if Position.Node = null then
791 raise Constraint_Error with
792 "Position cursor equals No_Element";
795 if Position.Container /= Container'Unrestricted_Access then
796 raise Program_Error with
797 "Position cursor designates wrong set";
800 pragma Assert (Vet (Container.Tree, Position.Node),
801 "bad cursor in Update_Element_Preserving_Key");
804 E : Element_Type renames Position.Node.Element;
805 K : constant Key_Type := Key (E);
807 B : Natural renames Tree.Busy;
808 L : Natural renames Tree.Lock;
826 if Equivalent_Keys (K, Key (E)) then
832 X : Node_Access := Position.Node;
834 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
838 raise Program_Error with "key was modified";
839 end Update_Element_Preserving_Key;
847 function Has_Element (Position : Cursor) return Boolean is
849 return Position /= No_Element;
856 procedure Include (Container : in out Set; New_Item : Element_Type) is
861 Insert (Container, New_Item, Position, Inserted);
864 if Container.Tree.Lock > 0 then
865 raise Program_Error with
866 "attempt to tamper with cursors (set is locked)";
869 Position.Node.Element := New_Item;
878 (Container : in out Set;
879 New_Item : Element_Type;
880 Position : out Cursor;
881 Inserted : out Boolean)
890 Position.Container := Container'Unrestricted_Access;
894 (Container : in out Set;
895 New_Item : Element_Type)
901 Insert (Container, New_Item, Position, Inserted);
904 raise Constraint_Error with
905 "attempt to insert element already in set";
909 ----------------------
910 -- Insert_Sans_Hint --
911 ----------------------
913 procedure Insert_Sans_Hint
914 (Tree : in out Tree_Type;
915 New_Item : Element_Type;
916 Node : out Node_Access;
917 Inserted : out Boolean)
919 function New_Node return Node_Access;
920 pragma Inline (New_Node);
922 procedure Insert_Post is
923 new Element_Keys.Generic_Insert_Post (New_Node);
925 procedure Conditional_Insert_Sans_Hint is
926 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
932 function New_Node return Node_Access is
934 return new Node_Type'(Parent => null,
937 Color => Red_Black_Trees.Red,
938 Element => New_Item);
941 -- Start of processing for Insert_Sans_Hint
944 Conditional_Insert_Sans_Hint
949 end Insert_Sans_Hint;
951 ----------------------
952 -- Insert_With_Hint --
953 ----------------------
955 procedure Insert_With_Hint
956 (Dst_Tree : in out Tree_Type;
957 Dst_Hint : Node_Access;
958 Src_Node : Node_Access;
959 Dst_Node : out Node_Access)
963 function New_Node return Node_Access;
964 pragma Inline (New_Node);
966 procedure Insert_Post is
967 new Element_Keys.Generic_Insert_Post (New_Node);
969 procedure Insert_Sans_Hint is
970 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
972 procedure Local_Insert_With_Hint is
973 new Element_Keys.Generic_Conditional_Insert_With_Hint
981 function New_Node return Node_Access is
982 Node : constant Node_Access :=
983 new Node_Type'(Parent => null,
987 Element => Src_Node.Element);
992 -- Start of processing for Insert_With_Hint
995 Local_Insert_With_Hint
1001 end Insert_With_Hint;
1007 procedure Intersection (Target : in out Set; Source : Set) is
1009 Set_Ops.Intersection (Target.Tree, Source.Tree);
1012 function Intersection (Left, Right : Set) return Set is
1013 Tree : constant Tree_Type :=
1014 Set_Ops.Intersection (Left.Tree, Right.Tree);
1016 return Set'(Controlled with Tree);
1023 function Is_Empty (Container : Set) return Boolean is
1025 return Container.Tree.Length = 0;
1028 ------------------------
1029 -- Is_Equal_Node_Node --
1030 ------------------------
1032 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1034 return L.Element = R.Element;
1035 end Is_Equal_Node_Node;
1037 -----------------------------
1038 -- Is_Greater_Element_Node --
1039 -----------------------------
1041 function Is_Greater_Element_Node
1042 (Left : Element_Type;
1043 Right : Node_Access) return Boolean
1046 -- Compute e > node same as node < e
1048 return Right.Element < Left;
1049 end Is_Greater_Element_Node;
1051 --------------------------
1052 -- Is_Less_Element_Node --
1053 --------------------------
1055 function Is_Less_Element_Node
1056 (Left : Element_Type;
1057 Right : Node_Access) return Boolean
1060 return Left < Right.Element;
1061 end Is_Less_Element_Node;
1063 -----------------------
1064 -- Is_Less_Node_Node --
1065 -----------------------
1067 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1069 return L.Element < R.Element;
1070 end Is_Less_Node_Node;
1076 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1078 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1087 Process : not null access procedure (Position : Cursor))
1089 procedure Process_Node (Node : Node_Access);
1090 pragma Inline (Process_Node);
1092 procedure Local_Iterate is
1093 new Tree_Operations.Generic_Iteration (Process_Node);
1099 procedure Process_Node (Node : Node_Access) is
1101 Process (Cursor'(Container'Unrestricted_Access, Node));
1104 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1105 B : Natural renames T.Busy;
1107 -- Start of prccessing for Iterate
1127 function Last (Container : Set) return Cursor is
1129 if Container.Tree.Last = null then
1133 return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1140 function Last_Element (Container : Set) return Element_Type is
1142 if Container.Tree.Last = null then
1143 raise Constraint_Error with "set is empty";
1146 return Container.Tree.Last.Element;
1153 function Left (Node : Node_Access) return Node_Access is
1162 function Length (Container : Set) return Count_Type is
1164 return Container.Tree.Length;
1172 new Tree_Operations.Generic_Move (Clear);
1174 procedure Move (Target : in out Set; Source : in out Set) is
1176 Move (Target => Target.Tree, Source => Source.Tree);
1183 function Next (Position : Cursor) return Cursor is
1185 if Position = No_Element then
1189 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1190 "bad cursor in Next");
1193 Node : constant Node_Access :=
1194 Tree_Operations.Next (Position.Node);
1201 return Cursor'(Position.Container, Node);
1205 procedure Next (Position : in out Cursor) is
1207 Position := Next (Position);
1214 function Overlap (Left, Right : Set) return Boolean is
1216 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1223 function Parent (Node : Node_Access) return Node_Access is
1232 function Previous (Position : Cursor) return Cursor is
1234 if Position = No_Element then
1238 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1239 "bad cursor in Previous");
1242 Node : constant Node_Access :=
1243 Tree_Operations.Previous (Position.Node);
1250 return Cursor'(Position.Container, Node);
1254 procedure Previous (Position : in out Cursor) is
1256 Position := Previous (Position);
1263 procedure Query_Element
1265 Process : not null access procedure (Element : Element_Type))
1268 if Position.Node = null then
1269 raise Constraint_Error with "Position cursor equals No_Element";
1272 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1273 "bad cursor in Query_Element");
1276 T : Tree_Type renames Position.Container.Tree;
1278 B : Natural renames T.Busy;
1279 L : Natural renames T.Lock;
1286 Process (Position.Node.Element);
1304 (Stream : access Root_Stream_Type'Class;
1305 Container : out Set)
1308 (Stream : access Root_Stream_Type'Class) return Node_Access;
1309 pragma Inline (Read_Node);
1312 new Tree_Operations.Generic_Read (Clear, Read_Node);
1319 (Stream : access Root_Stream_Type'Class) return Node_Access
1321 Node : Node_Access := new Node_Type;
1324 Element_Type'Read (Stream, Node.Element);
1333 -- Start of processing for Read
1336 Read (Stream, Container.Tree);
1340 (Stream : access Root_Stream_Type'Class;
1344 raise Program_Error with "attempt to stream set cursor";
1351 procedure Replace (Container : in out Set; New_Item : Element_Type) is
1352 Node : constant Node_Access :=
1353 Element_Keys.Find (Container.Tree, New_Item);
1357 raise Constraint_Error with
1358 "attempt to replace element not in set";
1361 if Container.Tree.Lock > 0 then
1362 raise Program_Error with
1363 "attempt to tamper with cursors (set is locked)";
1366 Node.Element := New_Item;
1369 ---------------------
1370 -- Replace_Element --
1371 ---------------------
1373 procedure Replace_Element
1374 (Tree : in out Tree_Type;
1376 Item : Element_Type)
1379 if Item < Node.Element
1380 or else Node.Element < Item
1384 if Tree.Lock > 0 then
1385 raise Program_Error with
1386 "attempt to tamper with cursors (set is locked)";
1389 Node.Element := Item;
1393 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
1395 Insert_New_Item : declare
1396 function New_Node return Node_Access;
1397 pragma Inline (New_Node);
1399 procedure Insert_Post is
1400 new Element_Keys.Generic_Insert_Post (New_Node);
1403 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1409 function New_Node return Node_Access is
1411 Node.Element := Item;
1413 Node.Parent := null;
1420 Result : Node_Access;
1423 -- Start of processing for Insert_New_Item
1430 Success => Inserted); -- TODO: change param name
1433 pragma Assert (Result = Node);
1438 null; -- Assignment must have failed
1439 end Insert_New_Item;
1441 Reinsert_Old_Element : declare
1442 function New_Node return Node_Access;
1443 pragma Inline (New_Node);
1445 procedure Insert_Post is
1446 new Element_Keys.Generic_Insert_Post (New_Node);
1449 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1455 function New_Node return Node_Access is
1458 Node.Parent := null;
1465 Result : Node_Access;
1468 -- Start of processing for Reinsert_Old_Element
1473 Key => Node.Element,
1475 Success => Inserted); -- TODO: change param name
1478 null; -- Assignment must have failed
1479 end Reinsert_Old_Element;
1481 raise Program_Error with "attempt to replace existing element";
1482 end Replace_Element;
1484 procedure Replace_Element
1485 (Container : in out Set;
1487 New_Item : Element_Type)
1490 if Position.Node = null then
1491 raise Constraint_Error with
1492 "Position cursor equals No_Element";
1495 if Position.Container /= Container'Unrestricted_Access then
1496 raise Program_Error with
1497 "Position cursor designates wrong set";
1500 pragma Assert (Vet (Container.Tree, Position.Node),
1501 "bad cursor in Replace_Element");
1503 Replace_Element (Container.Tree, Position.Node, New_Item);
1504 end Replace_Element;
1506 ---------------------
1507 -- Reverse_Iterate --
1508 ---------------------
1510 procedure Reverse_Iterate
1512 Process : not null access procedure (Position : Cursor))
1514 procedure Process_Node (Node : Node_Access);
1515 pragma Inline (Process_Node);
1517 procedure Local_Reverse_Iterate is
1518 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1524 procedure Process_Node (Node : Node_Access) is
1526 Process (Cursor'(Container'Unrestricted_Access, Node));
1529 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1530 B : Natural renames T.Busy;
1532 -- Start of processing for Reverse_Iterate
1538 Local_Reverse_Iterate (T);
1546 end Reverse_Iterate;
1552 function Right (Node : Node_Access) return Node_Access is
1561 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1563 Node.Color := Color;
1570 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1579 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1581 Node.Parent := Parent;
1588 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1590 Node.Right := Right;
1593 --------------------------
1594 -- Symmetric_Difference --
1595 --------------------------
1597 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1599 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1600 end Symmetric_Difference;
1602 function Symmetric_Difference (Left, Right : Set) return Set is
1603 Tree : constant Tree_Type :=
1604 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1606 return Set'(Controlled with Tree);
1607 end Symmetric_Difference;
1613 function To_Set (New_Item : Element_Type) return Set is
1619 Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
1620 return Set'(Controlled with Tree);
1627 procedure Union (Target : in out Set; Source : Set) is
1629 Set_Ops.Union (Target.Tree, Source.Tree);
1632 function Union (Left, Right : Set) return Set is
1633 Tree : constant Tree_Type :=
1634 Set_Ops.Union (Left.Tree, Right.Tree);
1636 return Set'(Controlled with Tree);
1644 (Stream : access Root_Stream_Type'Class;
1647 procedure Write_Node
1648 (Stream : access Root_Stream_Type'Class;
1649 Node : Node_Access);
1650 pragma Inline (Write_Node);
1653 new Tree_Operations.Generic_Write (Write_Node);
1659 procedure Write_Node
1660 (Stream : access Root_Stream_Type'Class;
1664 Element_Type'Write (Stream, Node.Element);
1667 -- Start of processing for Write
1670 Write (Stream, Container.Tree);
1674 (Stream : access Root_Stream_Type'Class;
1678 raise Program_Error with "attempt to stream set cursor";
1681 end Ada.Containers.Ordered_Sets;