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 _ M U L T I S E T S --
9 -- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada.Unchecked_Deallocation;
32 with Ada.Containers.Red_Black_Trees.Generic_Operations;
33 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
35 with Ada.Containers.Red_Black_Trees.Generic_Keys;
36 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
38 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
39 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
41 package body Ada.Containers.Ordered_Multisets is
43 -----------------------------
44 -- Node Access Subprograms --
45 -----------------------------
47 -- These subprograms provide a functional interface to access fields
48 -- of a node, and a procedural interface for modifying these values.
50 function Color (Node : Node_Access) return Color_Type;
51 pragma Inline (Color);
53 function Left (Node : Node_Access) return Node_Access;
56 function Parent (Node : Node_Access) return Node_Access;
57 pragma Inline (Parent);
59 function Right (Node : Node_Access) return Node_Access;
60 pragma Inline (Right);
62 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
63 pragma Inline (Set_Parent);
65 procedure Set_Left (Node : Node_Access; Left : Node_Access);
66 pragma Inline (Set_Left);
68 procedure Set_Right (Node : Node_Access; Right : Node_Access);
69 pragma Inline (Set_Right);
71 procedure Set_Color (Node : Node_Access; Color : Color_Type);
72 pragma Inline (Set_Color);
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 function Copy_Node (Source : Node_Access) return Node_Access;
79 pragma Inline (Copy_Node);
81 procedure Free (X : in out Node_Access);
83 procedure Insert_Sans_Hint
84 (Tree : in out Tree_Type;
85 New_Item : Element_Type;
86 Node : out Node_Access);
88 procedure Insert_With_Hint
89 (Dst_Tree : in out Tree_Type;
90 Dst_Hint : Node_Access;
91 Src_Node : Node_Access;
92 Dst_Node : out Node_Access);
94 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
95 pragma Inline (Is_Equal_Node_Node);
97 function Is_Greater_Element_Node
99 Right : Node_Access) return Boolean;
100 pragma Inline (Is_Greater_Element_Node);
102 function Is_Less_Element_Node
103 (Left : Element_Type;
104 Right : Node_Access) return Boolean;
105 pragma Inline (Is_Less_Element_Node);
107 function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
108 pragma Inline (Is_Less_Node_Node);
110 procedure Replace_Element
111 (Tree : in out Tree_Type;
113 Item : Element_Type);
115 --------------------------
116 -- Local Instantiations --
117 --------------------------
119 package Tree_Operations is
120 new Red_Black_Trees.Generic_Operations (Tree_Types);
122 procedure Delete_Tree is
123 new Tree_Operations.Generic_Delete_Tree (Free);
125 function Copy_Tree is
126 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
131 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
133 package Element_Keys is
134 new Red_Black_Trees.Generic_Keys
135 (Tree_Operations => Tree_Operations,
136 Key_Type => Element_Type,
137 Is_Less_Key_Node => Is_Less_Element_Node,
138 Is_Greater_Key_Node => Is_Greater_Element_Node);
141 new Generic_Set_Operations
142 (Tree_Operations => Tree_Operations,
143 Insert_With_Hint => Insert_With_Hint,
144 Copy_Tree => Copy_Tree,
145 Delete_Tree => Delete_Tree,
146 Is_Less => Is_Less_Node_Node,
153 function "<" (Left, Right : Cursor) return Boolean is
155 if Left.Node = null then
156 raise Constraint_Error with "Left cursor equals No_Element";
159 if Right.Node = null then
160 raise Constraint_Error with "Right cursor equals No_Element";
163 pragma Assert (Vet (Left.Container.Tree, Left.Node),
164 "bad Left cursor in ""<""");
166 pragma Assert (Vet (Right.Container.Tree, Right.Node),
167 "bad Right cursor in ""<""");
169 return Left.Node.Element < Right.Node.Element;
172 function "<" (Left : Cursor; Right : Element_Type)
175 if Left.Node = null then
176 raise Constraint_Error with "Left cursor equals No_Element";
179 pragma Assert (Vet (Left.Container.Tree, Left.Node),
180 "bad Left cursor in ""<""");
182 return Left.Node.Element < Right;
185 function "<" (Left : Element_Type; Right : Cursor)
188 if Right.Node = null then
189 raise Constraint_Error with "Right cursor equals No_Element";
192 pragma Assert (Vet (Right.Container.Tree, Right.Node),
193 "bad Right cursor in ""<""");
195 return Left < Right.Node.Element;
202 function "=" (Left, Right : Set) return Boolean is
204 return Is_Equal (Left.Tree, Right.Tree);
211 function ">" (Left, Right : Cursor) return Boolean is
213 if Left.Node = null then
214 raise Constraint_Error with "Left cursor equals No_Element";
217 if Right.Node = null then
218 raise Constraint_Error with "Right cursor equals No_Element";
221 pragma Assert (Vet (Left.Container.Tree, Left.Node),
222 "bad Left cursor in "">""");
224 pragma Assert (Vet (Right.Container.Tree, Right.Node),
225 "bad Right cursor in "">""");
227 -- L > R same as R < L
229 return Right.Node.Element < Left.Node.Element;
232 function ">" (Left : Cursor; Right : Element_Type)
235 if Left.Node = null then
236 raise Constraint_Error with "Left cursor equals No_Element";
239 pragma Assert (Vet (Left.Container.Tree, Left.Node),
240 "bad Left cursor in "">""");
242 return Right < Left.Node.Element;
245 function ">" (Left : Element_Type; Right : Cursor)
248 if Right.Node = null then
249 raise Constraint_Error with "Right cursor equals No_Element";
252 pragma Assert (Vet (Right.Container.Tree, Right.Node),
253 "bad Right cursor in "">""");
255 return Right.Node.Element < Left;
262 procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree);
264 procedure Adjust (Container : in out Set) is
266 Adjust (Container.Tree);
273 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
274 Node : constant Node_Access :=
275 Element_Keys.Ceiling (Container.Tree, Item);
282 return Cursor'(Container'Unrestricted_Access, Node);
290 new Tree_Operations.Generic_Clear (Delete_Tree);
292 procedure Clear (Container : in out Set) is
294 Clear (Container.Tree);
301 function Color (Node : Node_Access) return Color_Type is
310 function Contains (Container : Set; Item : Element_Type) return Boolean is
312 return Find (Container, Item) /= No_Element;
319 function Copy_Node (Source : Node_Access) return Node_Access is
320 Target : constant Node_Access :=
321 new Node_Type'(Parent => null,
324 Color => Source.Color,
325 Element => Source.Element);
334 procedure Delete (Container : in out Set; Item : Element_Type) is
335 Tree : Tree_Type renames Container.Tree;
336 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
337 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
342 raise Constraint_Error with
343 "attempt to delete element not in set";
348 Node := Tree_Operations.Next (Node);
349 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
352 exit when Node = Done;
356 procedure Delete (Container : in out Set; Position : in out Cursor) is
358 if Position.Node = null then
359 raise Constraint_Error with "Position cursor equals No_Element";
362 if Position.Container /= Container'Unrestricted_Access then
363 raise Program_Error with "Position cursor designates wrong set";
366 pragma Assert (Vet (Container.Tree, Position.Node),
367 "bad cursor in Delete");
369 Delete_Node_Sans_Free (Container.Tree, Position.Node);
370 Free (Position.Node);
372 Position.Container := null;
379 procedure Delete_First (Container : in out Set) is
380 Tree : Tree_Type renames Container.Tree;
381 X : Node_Access := Tree.First;
388 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
396 procedure Delete_Last (Container : in out Set) is
397 Tree : Tree_Type renames Container.Tree;
398 X : Node_Access := Tree.Last;
405 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
413 procedure Difference (Target : in out Set; Source : Set) is
415 Set_Ops.Difference (Target.Tree, Source.Tree);
418 function Difference (Left, Right : Set) return Set is
419 Tree : constant Tree_Type :=
420 Set_Ops.Difference (Left.Tree, Right.Tree);
422 return Set'(Controlled with Tree);
429 function Element (Position : Cursor) return Element_Type is
431 if Position.Node = null then
432 raise Constraint_Error with "Position cursor equals No_Element";
435 pragma Assert (Vet (Position.Container.Tree, Position.Node),
436 "bad cursor in Element");
438 return Position.Node.Element;
441 -------------------------
442 -- Equivalent_Elements --
443 -------------------------
445 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
454 end Equivalent_Elements;
456 ---------------------
457 -- Equivalent_Sets --
458 ---------------------
460 function Equivalent_Sets (Left, Right : Set) return Boolean is
462 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
463 pragma Inline (Is_Equivalent_Node_Node);
465 function Is_Equivalent is
466 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
468 -----------------------------
469 -- Is_Equivalent_Node_Node --
470 -----------------------------
472 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
474 if L.Element < R.Element then
476 elsif R.Element < L.Element then
481 end Is_Equivalent_Node_Node;
483 -- Start of processing for Equivalent_Sets
486 return Is_Equivalent (Left.Tree, Right.Tree);
493 procedure Exclude (Container : in out Set; Item : Element_Type) is
494 Tree : Tree_Type renames Container.Tree;
495 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
496 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
499 while Node /= Done loop
501 Node := Tree_Operations.Next (Node);
502 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
511 function Find (Container : Set; Item : Element_Type) return Cursor is
512 Node : constant Node_Access :=
513 Element_Keys.Find (Container.Tree, Item);
520 return Cursor'(Container'Unrestricted_Access, Node);
527 function First (Container : Set) return Cursor is
529 if Container.Tree.First = null then
533 return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
540 function First_Element (Container : Set) return Element_Type is
542 if Container.Tree.First = null then
543 raise Constraint_Error with "set is empty";
546 return Container.Tree.First.Element;
553 function Floor (Container : Set; Item : Element_Type) return Cursor is
554 Node : constant Node_Access :=
555 Element_Keys.Floor (Container.Tree, Item);
562 return Cursor'(Container'Unrestricted_Access, Node);
569 procedure Free (X : in out Node_Access) is
570 procedure Deallocate is
571 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
587 package body Generic_Keys is
589 -----------------------
590 -- Local Subprograms --
591 -----------------------
593 function Is_Greater_Key_Node
595 Right : Node_Access) return Boolean;
596 pragma Inline (Is_Greater_Key_Node);
598 function Is_Less_Key_Node
600 Right : Node_Access) return Boolean;
601 pragma Inline (Is_Less_Key_Node);
603 --------------------------
604 -- Local_Instantiations --
605 --------------------------
608 new Red_Black_Trees.Generic_Keys
609 (Tree_Operations => Tree_Operations,
610 Key_Type => Key_Type,
611 Is_Less_Key_Node => Is_Less_Key_Node,
612 Is_Greater_Key_Node => Is_Greater_Key_Node);
618 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
619 Node : constant Node_Access :=
620 Key_Keys.Ceiling (Container.Tree, Key);
627 return Cursor'(Container'Unrestricted_Access, Node);
634 function Contains (Container : Set; Key : Key_Type) return Boolean is
636 return Find (Container, Key) /= No_Element;
643 procedure Delete (Container : in out Set; Key : Key_Type) is
644 Tree : Tree_Type renames Container.Tree;
645 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
646 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
651 raise Constraint_Error with "attempt to delete key not in set";
656 Node := Tree_Operations.Next (Node);
657 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
660 exit when Node = Done;
668 function Element (Container : Set; Key : Key_Type) return Element_Type is
669 Node : constant Node_Access :=
670 Key_Keys.Find (Container.Tree, Key);
673 raise Constraint_Error with "key not in set";
679 ---------------------
680 -- Equivalent_Keys --
681 ---------------------
683 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
698 procedure Exclude (Container : in out Set; Key : Key_Type) is
699 Tree : Tree_Type renames Container.Tree;
700 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
701 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
705 while Node /= Done loop
707 Node := Tree_Operations.Next (Node);
708 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
717 function Find (Container : Set; Key : Key_Type) return Cursor is
718 Node : constant Node_Access :=
719 Key_Keys.Find (Container.Tree, Key);
726 return Cursor'(Container'Unrestricted_Access, Node);
733 function Floor (Container : Set; Key : Key_Type) return Cursor is
734 Node : constant Node_Access :=
735 Key_Keys.Floor (Container.Tree, Key);
742 return Cursor'(Container'Unrestricted_Access, Node);
745 -------------------------
746 -- Is_Greater_Key_Node --
747 -------------------------
749 function Is_Greater_Key_Node
751 Right : Node_Access) return Boolean is
753 return Key (Right.Element) < Left;
754 end Is_Greater_Key_Node;
756 ----------------------
757 -- Is_Less_Key_Node --
758 ----------------------
760 function Is_Less_Key_Node
762 Right : Node_Access) return Boolean is
764 return Left < Key (Right.Element);
765 end Is_Less_Key_Node;
774 Process : not null access procedure (Position : Cursor))
776 procedure Process_Node (Node : Node_Access);
777 pragma Inline (Process_Node);
779 procedure Local_Iterate is
780 new Key_Keys.Generic_Iteration (Process_Node);
786 procedure Process_Node (Node : Node_Access) is
788 Process (Cursor'(Container'Unrestricted_Access, Node));
791 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
792 B : Natural renames T.Busy;
794 -- Start of processing for Iterate
800 Local_Iterate (T, Key);
814 function Key (Position : Cursor) return Key_Type is
816 if Position.Node = null then
817 raise Constraint_Error with
818 "Position cursor equals No_Element";
821 pragma Assert (Vet (Position.Container.Tree, Position.Node),
822 "bad cursor in Key");
824 return Key (Position.Node.Element);
827 ---------------------
828 -- Reverse_Iterate --
829 ---------------------
831 procedure Reverse_Iterate
834 Process : not null access procedure (Position : Cursor))
836 procedure Process_Node (Node : Node_Access);
837 pragma Inline (Process_Node);
839 procedure Local_Reverse_Iterate is
840 new Key_Keys.Generic_Reverse_Iteration (Process_Node);
846 procedure Process_Node (Node : Node_Access) is
848 Process (Cursor'(Container'Unrestricted_Access, Node));
851 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
852 B : Natural renames T.Busy;
854 -- Start of processing for Reverse_Iterate
860 Local_Reverse_Iterate (T, Key);
874 procedure Update_Element
875 (Container : in out Set;
877 Process : not null access procedure (Element : in out Element_Type))
879 Tree : Tree_Type renames Container.Tree;
880 Node : constant Node_Access := Position.Node;
884 raise Constraint_Error with
885 "Position cursor equals No_Element";
888 if Position.Container /= Container'Unrestricted_Access then
889 raise Program_Error with
890 "Position cursor designates wrong set";
893 pragma Assert (Vet (Tree, Node),
894 "bad cursor in Update_Element");
897 E : Element_Type renames Node.Element;
898 K : constant Key_Type := Key (E);
900 B : Natural renames Tree.Busy;
901 L : Natural renames Tree.Lock;
919 if Equivalent_Keys (Left => K, Right => Key (E)) then
924 -- Delete_Node checks busy-bit
926 Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
928 Insert_New_Item : declare
929 function New_Node return Node_Access;
930 pragma Inline (New_Node);
932 procedure Insert_Post is
933 new Element_Keys.Generic_Insert_Post (New_Node);
935 procedure Unconditional_Insert is
936 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
942 function New_Node return Node_Access is
944 Node.Color := Red_Black_Trees.Red;
952 Result : Node_Access;
954 -- Start of processing for Insert_New_Item
962 pragma Assert (Result = Node);
972 function Has_Element (Position : Cursor) return Boolean is
974 return Position /= No_Element;
981 procedure Insert (Container : in out Set; New_Item : Element_Type) is
983 pragma Unreferenced (Position);
985 Insert (Container, New_Item, Position);
989 (Container : in out Set;
990 New_Item : Element_Type;
991 Position : out Cursor)
994 Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
995 Position.Container := Container'Unrestricted_Access;
998 ----------------------
999 -- Insert_Sans_Hint --
1000 ----------------------
1002 procedure Insert_Sans_Hint
1003 (Tree : in out Tree_Type;
1004 New_Item : Element_Type;
1005 Node : out Node_Access)
1007 function New_Node return Node_Access;
1008 pragma Inline (New_Node);
1010 procedure Insert_Post is
1011 new Element_Keys.Generic_Insert_Post (New_Node);
1013 procedure Unconditional_Insert is
1014 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1020 function New_Node return Node_Access is
1021 Node : constant Node_Access :=
1022 new Node_Type'(Parent => null,
1025 Color => Red_Black_Trees.Red,
1026 Element => New_Item);
1031 -- Start of processing for Insert_Sans_Hint
1034 Unconditional_Insert (Tree, New_Item, Node);
1035 end Insert_Sans_Hint;
1037 ----------------------
1038 -- Insert_With_Hint --
1039 ----------------------
1041 procedure Insert_With_Hint
1042 (Dst_Tree : in out Tree_Type;
1043 Dst_Hint : Node_Access;
1044 Src_Node : Node_Access;
1045 Dst_Node : out Node_Access)
1047 function New_Node return Node_Access;
1048 pragma Inline (New_Node);
1050 procedure Insert_Post is
1051 new Element_Keys.Generic_Insert_Post (New_Node);
1053 procedure Insert_Sans_Hint is
1054 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1056 procedure Local_Insert_With_Hint is
1057 new Element_Keys.Generic_Unconditional_Insert_With_Hint
1065 function New_Node return Node_Access is
1066 Node : constant Node_Access :=
1067 new Node_Type'(Parent => null,
1071 Element => Src_Node.Element);
1076 -- Start of processing for Insert_With_Hint
1079 Local_Insert_With_Hint
1084 end Insert_With_Hint;
1090 procedure Intersection (Target : in out Set; Source : Set) is
1092 Set_Ops.Intersection (Target.Tree, Source.Tree);
1095 function Intersection (Left, Right : Set) return Set is
1096 Tree : constant Tree_Type :=
1097 Set_Ops.Intersection (Left.Tree, Right.Tree);
1099 return Set'(Controlled with Tree);
1106 function Is_Empty (Container : Set) return Boolean is
1108 return Container.Tree.Length = 0;
1111 ------------------------
1112 -- Is_Equal_Node_Node --
1113 ------------------------
1115 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1117 return L.Element = R.Element;
1118 end Is_Equal_Node_Node;
1120 -----------------------------
1121 -- Is_Greater_Element_Node --
1122 -----------------------------
1124 function Is_Greater_Element_Node
1125 (Left : Element_Type;
1126 Right : Node_Access) return Boolean
1129 -- e > node same as node < e
1131 return Right.Element < Left;
1132 end Is_Greater_Element_Node;
1134 --------------------------
1135 -- Is_Less_Element_Node --
1136 --------------------------
1138 function Is_Less_Element_Node
1139 (Left : Element_Type;
1140 Right : Node_Access) return Boolean
1143 return Left < Right.Element;
1144 end Is_Less_Element_Node;
1146 -----------------------
1147 -- Is_Less_Node_Node --
1148 -----------------------
1150 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1152 return L.Element < R.Element;
1153 end Is_Less_Node_Node;
1159 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1161 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1170 Process : not null access procedure (Position : Cursor))
1172 procedure Process_Node (Node : Node_Access);
1173 pragma Inline (Process_Node);
1175 procedure Local_Iterate is
1176 new Tree_Operations.Generic_Iteration (Process_Node);
1182 procedure Process_Node (Node : Node_Access) is
1184 Process (Cursor'(Container'Unrestricted_Access, Node));
1187 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1188 B : Natural renames T.Busy;
1190 -- Start of processing for Iterate
1208 Item : Element_Type;
1209 Process : not null access procedure (Position : Cursor))
1211 procedure Process_Node (Node : Node_Access);
1212 pragma Inline (Process_Node);
1214 procedure Local_Iterate is
1215 new Element_Keys.Generic_Iteration (Process_Node);
1221 procedure Process_Node (Node : Node_Access) is
1223 Process (Cursor'(Container'Unrestricted_Access, Node));
1226 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1227 B : Natural renames T.Busy;
1229 -- Start of processing for Iterate
1235 Local_Iterate (T, Item);
1249 function Last (Container : Set) return Cursor is
1251 if Container.Tree.Last = null then
1255 return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1262 function Last_Element (Container : Set) return Element_Type is
1264 if Container.Tree.Last = null then
1265 raise Constraint_Error with "set is empty";
1268 return Container.Tree.Last.Element;
1275 function Left (Node : Node_Access) return Node_Access is
1284 function Length (Container : Set) return Count_Type is
1286 return Container.Tree.Length;
1294 new Tree_Operations.Generic_Move (Clear);
1296 procedure Move (Target : in out Set; Source : in out Set) is
1298 Move (Target => Target.Tree, Source => Source.Tree);
1305 procedure Next (Position : in out Cursor)
1308 Position := Next (Position);
1311 function Next (Position : Cursor) return Cursor is
1313 if Position = No_Element then
1317 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1318 "bad cursor in Next");
1321 Node : constant Node_Access :=
1322 Tree_Operations.Next (Position.Node);
1328 return Cursor'(Position.Container, Node);
1336 function Overlap (Left, Right : Set) return Boolean is
1338 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1345 function Parent (Node : Node_Access) return Node_Access is
1354 procedure Previous (Position : in out Cursor)
1357 Position := Previous (Position);
1360 function Previous (Position : Cursor) return Cursor is
1362 if Position = No_Element then
1366 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1367 "bad cursor in Previous");
1370 Node : constant Node_Access :=
1371 Tree_Operations.Previous (Position.Node);
1377 return Cursor'(Position.Container, Node);
1385 procedure Query_Element
1387 Process : not null access procedure (Element : Element_Type))
1390 if Position.Node = null then
1391 raise Constraint_Error with "Position cursor equals No_Element";
1394 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1395 "bad cursor in Query_Element");
1398 T : Tree_Type renames Position.Container.Tree;
1400 B : Natural renames T.Busy;
1401 L : Natural renames T.Lock;
1408 Process (Position.Node.Element);
1426 (Stream : not null access Root_Stream_Type'Class;
1427 Container : out Set)
1430 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1431 pragma Inline (Read_Node);
1434 new Tree_Operations.Generic_Read (Clear, Read_Node);
1441 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1443 Node : Node_Access := new Node_Type;
1445 Element_Type'Read (Stream, Node.Element);
1449 Free (Node); -- Note that Free deallocates elem too
1453 -- Start of processing for Read
1456 Read (Stream, Container.Tree);
1460 (Stream : not null access Root_Stream_Type'Class;
1464 raise Program_Error with "attempt to stream set cursor";
1467 ---------------------
1468 -- Replace_Element --
1469 ---------------------
1471 procedure Replace_Element
1472 (Tree : in out Tree_Type;
1474 Item : Element_Type)
1477 if Item < Node.Element
1478 or else Node.Element < Item
1482 if Tree.Lock > 0 then
1483 raise Program_Error with
1484 "attempt to tamper with elements (set is locked)";
1487 Node.Element := Item;
1491 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
1493 Insert_New_Item : declare
1494 function New_Node return Node_Access;
1495 pragma Inline (New_Node);
1497 procedure Insert_Post is
1498 new Element_Keys.Generic_Insert_Post (New_Node);
1500 procedure Unconditional_Insert is
1501 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1507 function New_Node return Node_Access is
1509 Node.Element := Item;
1510 Node.Color := Red_Black_Trees.Red;
1511 Node.Parent := null;
1518 Result : Node_Access;
1520 -- Start of processing for Insert_New_Item
1523 Unconditional_Insert
1528 pragma Assert (Result = Node);
1529 end Insert_New_Item;
1530 end Replace_Element;
1532 procedure Replace_Element
1533 (Container : in out Set;
1535 New_Item : Element_Type)
1538 if Position.Node = null then
1539 raise Constraint_Error with
1540 "Position cursor equals No_Element";
1543 if Position.Container /= Container'Unrestricted_Access then
1544 raise Program_Error with
1545 "Position cursor designates wrong set";
1548 pragma Assert (Vet (Container.Tree, Position.Node),
1549 "bad cursor in Replace_Element");
1551 Replace_Element (Container.Tree, Position.Node, New_Item);
1552 end Replace_Element;
1554 ---------------------
1555 -- Reverse_Iterate --
1556 ---------------------
1558 procedure Reverse_Iterate
1560 Process : not null access procedure (Position : Cursor))
1562 procedure Process_Node (Node : Node_Access);
1563 pragma Inline (Process_Node);
1565 procedure Local_Reverse_Iterate is
1566 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1572 procedure Process_Node (Node : Node_Access) is
1574 Process (Cursor'(Container'Unrestricted_Access, Node));
1577 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1578 B : Natural renames T.Busy;
1580 -- Start of processing for Reverse_Iterate
1586 Local_Reverse_Iterate (T);
1594 end Reverse_Iterate;
1596 procedure Reverse_Iterate
1598 Item : Element_Type;
1599 Process : not null access procedure (Position : Cursor))
1601 procedure Process_Node (Node : Node_Access);
1602 pragma Inline (Process_Node);
1604 procedure Local_Reverse_Iterate is
1605 new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1611 procedure Process_Node (Node : Node_Access) is
1613 Process (Cursor'(Container'Unrestricted_Access, Node));
1616 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1617 B : Natural renames T.Busy;
1619 -- Start of processing for Reverse_Iterate
1625 Local_Reverse_Iterate (T, Item);
1633 end Reverse_Iterate;
1639 function Right (Node : Node_Access) return Node_Access is
1648 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1650 Node.Color := Color;
1657 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1666 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1668 Node.Parent := Parent;
1675 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1677 Node.Right := Right;
1680 --------------------------
1681 -- Symmetric_Difference --
1682 --------------------------
1684 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1686 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1687 end Symmetric_Difference;
1689 function Symmetric_Difference (Left, Right : Set) return Set is
1690 Tree : constant Tree_Type :=
1691 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1693 return Set'(Controlled with Tree);
1694 end Symmetric_Difference;
1700 function To_Set (New_Item : Element_Type) return Set is
1703 pragma Unreferenced (Node);
1705 Insert_Sans_Hint (Tree, New_Item, Node);
1706 return Set'(Controlled with Tree);
1713 procedure Union (Target : in out Set; Source : Set) is
1715 Set_Ops.Union (Target.Tree, Source.Tree);
1718 function Union (Left, Right : Set) return Set is
1719 Tree : constant Tree_Type :=
1720 Set_Ops.Union (Left.Tree, Right.Tree);
1722 return Set'(Controlled with Tree);
1730 (Stream : not null access Root_Stream_Type'Class;
1733 procedure Write_Node
1734 (Stream : not null access Root_Stream_Type'Class;
1735 Node : Node_Access);
1736 pragma Inline (Write_Node);
1739 new Tree_Operations.Generic_Write (Write_Node);
1745 procedure Write_Node
1746 (Stream : not null access Root_Stream_Type'Class;
1750 Element_Type'Write (Stream, Node.Element);
1753 -- Start of processing for Write
1756 Write (Stream, Container.Tree);
1760 (Stream : not null access Root_Stream_Type'Class;
1764 raise Program_Error with "attempt to stream set cursor";
1767 end Ada.Containers.Ordered_Multisets;