1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . --
6 -- I N D E F I N I T E _ O R D E R E D _ M U L T I S E T S --
10 -- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
12 -- This specification is derived from the Ada Reference Manual for use with --
13 -- GNAT. The copyright notice above, and the license provisions that follow --
14 -- apply solely to the contents of the part following the private keyword. --
16 -- GNAT is free software; you can redistribute it and/or modify it under --
17 -- terms of the GNU General Public License as published by the Free Soft- --
18 -- ware Foundation; either version 2, or (at your option) any later ver- --
19 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
20 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
21 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
22 -- for more details. You should have received a copy of the GNU General --
23 -- Public License distributed with GNAT; see file COPYING. If not, write --
24 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
25 -- Boston, MA 02110-1301, USA. --
27 -- As a special exception, if other files instantiate generics from this --
28 -- unit, or you link this unit with other files to produce an executable, --
29 -- this unit does not by itself cause the resulting executable to be --
30 -- covered by the GNU General Public License. This exception does not --
31 -- however invalidate any other reasons why the executable file might be --
32 -- covered by the GNU Public License. --
34 -- This unit was originally developed by Matthew J Heaney. --
35 ------------------------------------------------------------------------------
37 with Ada.Unchecked_Deallocation;
39 with Ada.Containers.Red_Black_Trees.Generic_Operations;
40 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
42 with Ada.Containers.Red_Black_Trees.Generic_Keys;
43 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
45 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
46 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
48 package body Ada.Containers.Indefinite_Ordered_Multisets is
50 -----------------------------
51 -- Node Access Subprograms --
52 -----------------------------
54 -- These subprograms provide a functional interface to access fields
55 -- of a node, and a procedural interface for modifying these values.
57 function Color (Node : Node_Access) return Color_Type;
58 pragma Inline (Color);
60 function Left (Node : Node_Access) return Node_Access;
63 function Parent (Node : Node_Access) return Node_Access;
64 pragma Inline (Parent);
66 function Right (Node : Node_Access) return Node_Access;
67 pragma Inline (Right);
69 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
70 pragma Inline (Set_Parent);
72 procedure Set_Left (Node : Node_Access; Left : Node_Access);
73 pragma Inline (Set_Left);
75 procedure Set_Right (Node : Node_Access; Right : Node_Access);
76 pragma Inline (Set_Right);
78 procedure Set_Color (Node : Node_Access; Color : Color_Type);
79 pragma Inline (Set_Color);
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
85 function Copy_Node (Source : Node_Access) return Node_Access;
86 pragma Inline (Copy_Node);
88 procedure Free (X : in out Node_Access);
90 procedure Insert_Sans_Hint
91 (Tree : in out Tree_Type;
92 New_Item : Element_Type;
93 Node : out Node_Access);
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);
137 procedure Free_Element is
138 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
141 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
144 new Generic_Set_Operations
145 (Tree_Operations => Tree_Operations,
146 Insert_With_Hint => Insert_With_Hint,
147 Copy_Tree => Copy_Tree,
148 Delete_Tree => Delete_Tree,
149 Is_Less => Is_Less_Node_Node,
152 package Element_Keys is
153 new Red_Black_Trees.Generic_Keys
154 (Tree_Operations => Tree_Operations,
155 Key_Type => Element_Type,
156 Is_Less_Key_Node => Is_Less_Element_Node,
157 Is_Greater_Key_Node => Is_Greater_Element_Node);
163 function "<" (Left, Right : Cursor) return Boolean is
166 or else Right.Node = null
168 raise Constraint_Error;
171 if Left.Node.Element = null
172 or else Right.Node.Element = null
177 pragma Assert (Vet (Left.Container.Tree, Left.Node),
178 "bad Left cursor in ""<""");
180 pragma Assert (Vet (Right.Container.Tree, Right.Node),
181 "bad Right cursor in ""<""");
183 return Left.Node.Element.all < Right.Node.Element.all;
186 function "<" (Left : Cursor; Right : Element_Type) return Boolean is
188 if Left.Node = null then
189 raise Constraint_Error;
192 if Left.Node.Element = null then
196 pragma Assert (Vet (Left.Container.Tree, Left.Node),
197 "bad Left cursor in ""<""");
199 return Left.Node.Element.all < Right;
202 function "<" (Left : Element_Type; Right : Cursor) return Boolean is
204 if Right.Node = null then
205 raise Constraint_Error;
208 if Right.Node.Element = null then
212 pragma Assert (Vet (Right.Container.Tree, Right.Node),
213 "bad Right cursor in ""<""");
215 return Left < Right.Node.Element.all;
222 function "=" (Left, Right : Set) return Boolean is
224 return Is_Equal (Left.Tree, Right.Tree);
231 function ">" (Left, Right : Cursor) return Boolean is
234 or else Right.Node = null
236 raise Constraint_Error;
239 if Left.Node.Element = null
240 or else Right.Node.Element = null
245 pragma Assert (Vet (Left.Container.Tree, Left.Node),
246 "bad Left cursor in "">""");
248 pragma Assert (Vet (Right.Container.Tree, Right.Node),
249 "bad Right cursor in "">""");
251 -- L > R same as R < L
253 return Right.Node.Element.all < Left.Node.Element.all;
256 function ">" (Left : Cursor; Right : Element_Type) return Boolean is
258 if Left.Node = null then
259 raise Constraint_Error;
262 if Left.Node.Element = null then
266 pragma Assert (Vet (Left.Container.Tree, Left.Node),
267 "bad Left cursor in "">""");
269 return Right < Left.Node.Element.all;
272 function ">" (Left : Element_Type; Right : Cursor) return Boolean is
274 if Right.Node = null then
275 raise Constraint_Error;
278 if Right.Node.Element = null then
282 pragma Assert (Vet (Right.Container.Tree, Right.Node),
283 "bad Right cursor in "">""");
285 return Right.Node.Element.all < Left;
293 new Tree_Operations.Generic_Adjust (Copy_Tree);
295 procedure Adjust (Container : in out Set) is
297 Adjust (Container.Tree);
304 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
305 Node : constant Node_Access :=
306 Element_Keys.Ceiling (Container.Tree, Item);
313 return Cursor'(Container'Unrestricted_Access, Node);
321 new Tree_Operations.Generic_Clear (Delete_Tree);
323 procedure Clear (Container : in out Set) is
325 Clear (Container.Tree);
332 function Color (Node : Node_Access) return Color_Type is
341 function Contains (Container : Set; Item : Element_Type) return Boolean is
343 return Find (Container, Item) /= No_Element;
350 function Copy_Node (Source : Node_Access) return Node_Access is
351 X : Element_Access := new Element_Type'(Source.Element.all);
354 return new Node_Type'(Parent => null,
357 Color => Source.Color,
370 procedure Delete (Container : in out Set; Item : Element_Type) is
371 Tree : Tree_Type renames Container.Tree;
372 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
373 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
378 raise Constraint_Error;
383 Node := Tree_Operations.Next (Node);
384 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
387 exit when Node = Done;
391 procedure Delete (Container : in out Set; Position : in out Cursor) is
393 if Position.Node = null then
394 raise Constraint_Error;
397 if Position.Container /= Container'Unrestricted_Access then
401 pragma Assert (Vet (Container.Tree, Position.Node),
402 "bad cursor in Delete");
404 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
405 Free (Position.Node);
407 Position.Container := null;
414 procedure Delete_First (Container : in out Set) is
415 Tree : Tree_Type renames Container.Tree;
416 X : Node_Access := Tree.First;
423 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
431 procedure Delete_Last (Container : in out Set) is
432 Tree : Tree_Type renames Container.Tree;
433 X : Node_Access := Tree.Last;
440 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
448 procedure Difference (Target : in out Set; Source : Set) is
450 Set_Ops.Difference (Target.Tree, Source.Tree);
453 function Difference (Left, Right : Set) return Set is
454 Tree : constant Tree_Type :=
455 Set_Ops.Difference (Left.Tree, Right.Tree);
457 return Set'(Controlled with Tree);
464 function Element (Position : Cursor) return Element_Type is
466 if Position.Node = null then
467 raise Constraint_Error;
470 if Position.Node.Element = null then
474 pragma Assert (Vet (Position.Container.Tree, Position.Node),
475 "bad cursor in Element");
477 return Position.Node.Element.all;
480 -------------------------
481 -- Equivalent_Elements --
482 -------------------------
484 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
493 end Equivalent_Elements;
495 ---------------------
496 -- Equivalent_Sets --
497 ---------------------
499 function Equivalent_Sets (Left, Right : Set) return Boolean is
501 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
502 pragma Inline (Is_Equivalent_Node_Node);
504 function Is_Equivalent is
505 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
507 -----------------------------
508 -- Is_Equivalent_Node_Node --
509 -----------------------------
511 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
513 if L.Element.all < R.Element.all then
515 elsif R.Element.all < L.Element.all then
520 end Is_Equivalent_Node_Node;
522 -- Start of processing for Equivalent_Sets
525 return Is_Equivalent (Left.Tree, Right.Tree);
532 procedure Exclude (Container : in out Set; Item : Element_Type) is
533 Tree : Tree_Type renames Container.Tree;
534 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
535 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
539 while Node /= Done loop
541 Node := Tree_Operations.Next (Node);
542 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
551 function Find (Container : Set; Item : Element_Type) return Cursor is
552 Node : constant Node_Access :=
553 Element_Keys.Find (Container.Tree, Item);
560 return Cursor'(Container'Unrestricted_Access, Node);
567 function First (Container : Set) return Cursor is
569 if Container.Tree.First = null then
573 return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
580 function First_Element (Container : Set) return Element_Type is
582 if Container.Tree.First = null then
583 raise Constraint_Error;
586 if Container.Tree.First.Element = null then
590 return Container.Tree.First.Element.all;
597 function Floor (Container : Set; Item : Element_Type) return Cursor is
598 Node : constant Node_Access :=
599 Element_Keys.Floor (Container.Tree, Item);
606 return Cursor'(Container'Unrestricted_Access, Node);
613 procedure Free (X : in out Node_Access) is
614 procedure Deallocate is
615 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
627 Free_Element (X.Element);
642 package body Generic_Keys is
644 -----------------------
645 -- Local Subprograms --
646 -----------------------
648 function Is_Less_Key_Node
650 Right : Node_Access) return Boolean;
651 pragma Inline (Is_Less_Key_Node);
653 function Is_Greater_Key_Node
655 Right : Node_Access) return Boolean;
656 pragma Inline (Is_Greater_Key_Node);
658 --------------------------
659 -- Local Instantiations --
660 --------------------------
663 new Red_Black_Trees.Generic_Keys
664 (Tree_Operations => Tree_Operations,
665 Key_Type => Key_Type,
666 Is_Less_Key_Node => Is_Less_Key_Node,
667 Is_Greater_Key_Node => Is_Greater_Key_Node);
673 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
674 Node : constant Node_Access :=
675 Key_Keys.Ceiling (Container.Tree, Key);
682 return Cursor'(Container'Unrestricted_Access, Node);
689 function Contains (Container : Set; Key : Key_Type) return Boolean is
691 return Find (Container, Key) /= No_Element;
698 procedure Delete (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);
706 raise Constraint_Error;
711 Node := Tree_Operations.Next (Node);
712 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
715 exit when Node = Done;
723 function Element (Container : Set; Key : Key_Type) return Element_Type is
724 Node : constant Node_Access :=
725 Key_Keys.Find (Container.Tree, Key);
729 raise Constraint_Error;
732 return Node.Element.all;
735 ---------------------
736 -- Equivalent_Keys --
737 ---------------------
739 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
754 procedure Exclude (Container : in out Set; Key : Key_Type) is
755 Tree : Tree_Type renames Container.Tree;
756 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
757 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
761 while Node /= Done loop
763 Node := Tree_Operations.Next (Node);
764 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
773 function Find (Container : Set; Key : Key_Type) return Cursor is
774 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
781 return Cursor'(Container'Unrestricted_Access, Node);
788 function Floor (Container : Set; Key : Key_Type) return Cursor is
789 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
796 return Cursor'(Container'Unrestricted_Access, Node);
799 -------------------------
800 -- Is_Greater_Key_Node --
801 -------------------------
803 function Is_Greater_Key_Node
805 Right : Node_Access) return Boolean
808 return Key (Right.Element.all) < Left;
809 end Is_Greater_Key_Node;
811 ----------------------
812 -- Is_Less_Key_Node --
813 ----------------------
815 function Is_Less_Key_Node
817 Right : Node_Access) return Boolean
820 return Left < Key (Right.Element.all);
821 end Is_Less_Key_Node;
830 Process : not null access procedure (Position : Cursor))
832 procedure Process_Node (Node : Node_Access);
833 pragma Inline (Process_Node);
835 procedure Local_Iterate is
836 new Key_Keys.Generic_Iteration (Process_Node);
842 procedure Process_Node (Node : Node_Access) is
844 Process (Cursor'(Container'Unrestricted_Access, Node));
847 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
848 B : Natural renames T.Busy;
850 -- Start of processing for Iterate
856 Local_Iterate (T, Key);
870 function Key (Position : Cursor) return Key_Type is
872 if Position.Node = null then
873 raise Constraint_Error;
876 if Position.Node.Element = null then
880 pragma Assert (Vet (Position.Container.Tree, Position.Node),
881 "bad cursor in Key");
883 return Key (Position.Node.Element.all);
886 ---------------------
887 -- Reverse_Iterate --
888 ---------------------
890 procedure Reverse_Iterate
893 Process : not null access procedure (Position : Cursor))
895 procedure Process_Node (Node : Node_Access);
896 pragma Inline (Process_Node);
902 procedure Local_Reverse_Iterate is
903 new Key_Keys.Generic_Reverse_Iteration (Process_Node);
909 procedure Process_Node (Node : Node_Access) is
911 Process (Cursor'(Container'Unrestricted_Access, Node));
914 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
915 B : Natural renames T.Busy;
917 -- Start of processing for Reverse_Iterate
923 Local_Reverse_Iterate (T, Key);
933 -----------------------------------
934 -- Update_Element_Preserving_Key --
935 -----------------------------------
937 procedure Update_Element_Preserving_Key
938 (Container : in out Set;
940 Process : not null access procedure (Element : in out Element_Type))
942 Tree : Tree_Type renames Container.Tree;
945 if Position.Node = null then
946 raise Constraint_Error;
949 if Position.Node.Element = null then
953 if Position.Container /= Container'Unrestricted_Access then
957 pragma Assert (Vet (Container.Tree, Position.Node),
958 "bad cursor in Update_Element_Preserving_Key");
961 E : Element_Type renames Position.Node.Element.all;
962 K : constant Key_Type := Key (E);
964 B : Natural renames Tree.Busy;
965 L : Natural renames Tree.Lock;
983 if Equivalent_Keys (Left => K, Right => Key (E)) then
989 X : Node_Access := Position.Node;
991 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
996 end Update_Element_Preserving_Key;
1004 function Has_Element (Position : Cursor) return Boolean is
1006 return Position /= No_Element;
1013 procedure Insert (Container : in out Set; New_Item : Element_Type) is
1016 Insert (Container, New_Item, Position);
1020 (Container : in out Set;
1021 New_Item : Element_Type;
1022 Position : out Cursor)
1030 Position.Container := Container'Unrestricted_Access;
1033 ----------------------
1034 -- Insert_Sans_Hint --
1035 ----------------------
1037 procedure Insert_Sans_Hint
1038 (Tree : in out Tree_Type;
1039 New_Item : Element_Type;
1040 Node : out Node_Access)
1042 function New_Node return Node_Access;
1043 pragma Inline (New_Node);
1045 procedure Insert_Post is
1046 new Element_Keys.Generic_Insert_Post (New_Node);
1048 procedure Unconditional_Insert_Sans_Hint is
1049 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1055 function New_Node return Node_Access is
1056 X : Element_Access := new Element_Type'(New_Item);
1059 return new Node_Type'(Parent => null,
1062 Color => Red_Black_Trees.Red,
1071 -- Start of processing for Insert_Sans_Hint
1074 Unconditional_Insert_Sans_Hint
1078 end Insert_Sans_Hint;
1080 ----------------------
1081 -- Insert_With_Hint --
1082 ----------------------
1084 procedure Insert_With_Hint
1085 (Dst_Tree : in out Tree_Type;
1086 Dst_Hint : Node_Access;
1087 Src_Node : Node_Access;
1088 Dst_Node : out Node_Access)
1090 function New_Node return Node_Access;
1091 pragma Inline (New_Node);
1093 procedure Insert_Post is
1094 new Element_Keys.Generic_Insert_Post (New_Node);
1096 procedure Insert_Sans_Hint is
1097 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1099 procedure Local_Insert_With_Hint is
1100 new Element_Keys.Generic_Unconditional_Insert_With_Hint
1108 function New_Node return Node_Access is
1109 X : Element_Access := new Element_Type'(Src_Node.Element.all);
1112 return new Node_Type'(Parent => null,
1124 -- Start of processing for Insert_With_Hint
1127 Local_Insert_With_Hint
1130 Src_Node.Element.all,
1132 end Insert_With_Hint;
1138 procedure Intersection (Target : in out Set; Source : Set) is
1140 Set_Ops.Intersection (Target.Tree, Source.Tree);
1143 function Intersection (Left, Right : Set) return Set is
1144 Tree : constant Tree_Type :=
1145 Set_Ops.Intersection (Left.Tree, Right.Tree);
1147 return Set'(Controlled with Tree);
1154 function Is_Empty (Container : Set) return Boolean is
1156 return Container.Tree.Length = 0;
1159 ------------------------
1160 -- Is_Equal_Node_Node --
1161 ------------------------
1163 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1165 return L.Element.all = R.Element.all;
1166 end Is_Equal_Node_Node;
1168 -----------------------------
1169 -- Is_Greater_Element_Node --
1170 -----------------------------
1172 function Is_Greater_Element_Node
1173 (Left : Element_Type;
1174 Right : Node_Access) return Boolean
1177 -- e > node same as node < e
1179 return Right.Element.all < Left;
1180 end Is_Greater_Element_Node;
1182 --------------------------
1183 -- Is_Less_Element_Node --
1184 --------------------------
1186 function Is_Less_Element_Node
1187 (Left : Element_Type;
1188 Right : Node_Access) return Boolean
1191 return Left < Right.Element.all;
1192 end Is_Less_Element_Node;
1194 -----------------------
1195 -- Is_Less_Node_Node --
1196 -----------------------
1198 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1200 return L.Element.all < R.Element.all;
1201 end Is_Less_Node_Node;
1207 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1209 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1218 Item : Element_Type;
1219 Process : not null access procedure (Position : Cursor))
1221 procedure Process_Node (Node : Node_Access);
1222 pragma Inline (Process_Node);
1224 procedure Local_Iterate is
1225 new Element_Keys.Generic_Iteration (Process_Node);
1231 procedure Process_Node (Node : Node_Access) is
1233 Process (Cursor'(Container'Unrestricted_Access, Node));
1236 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1237 B : Natural renames T.Busy;
1239 -- Start of processing for Iterate
1245 Local_Iterate (T, Item);
1257 Process : not null access procedure (Position : Cursor))
1259 procedure Process_Node (Node : Node_Access);
1260 pragma Inline (Process_Node);
1262 procedure Local_Iterate is
1263 new Tree_Operations.Generic_Iteration (Process_Node);
1269 procedure Process_Node (Node : Node_Access) is
1271 Process (Cursor'(Container'Unrestricted_Access, Node));
1274 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1275 B : Natural renames T.Busy;
1277 -- Start of processing for Iterate
1297 function Last (Container : Set) return Cursor is
1299 if Container.Tree.Last = null then
1303 return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1310 function Last_Element (Container : Set) return Element_Type is
1312 if Container.Tree.Last = null then
1313 raise Constraint_Error;
1316 return Container.Tree.Last.Element.all;
1323 function Left (Node : Node_Access) return Node_Access is
1332 function Length (Container : Set) return Count_Type is
1334 return Container.Tree.Length;
1342 new Tree_Operations.Generic_Move (Clear);
1344 procedure Move (Target : in out Set; Source : in out Set) is
1346 Move (Target => Target.Tree, Source => Source.Tree);
1353 function Next (Position : Cursor) return Cursor is
1355 if Position = No_Element then
1359 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1360 "bad cursor in Next");
1363 Node : constant Node_Access :=
1364 Tree_Operations.Next (Position.Node);
1371 return Cursor'(Position.Container, Node);
1375 procedure Next (Position : in out Cursor) is
1377 Position := Next (Position);
1384 function Overlap (Left, Right : Set) return Boolean is
1386 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1393 function Parent (Node : Node_Access) return Node_Access is
1402 function Previous (Position : Cursor) return Cursor is
1404 if Position = No_Element then
1408 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1409 "bad cursor in Previous");
1412 Node : constant Node_Access :=
1413 Tree_Operations.Previous (Position.Node);
1420 return Cursor'(Position.Container, Node);
1424 procedure Previous (Position : in out Cursor) is
1426 Position := Previous (Position);
1433 procedure Query_Element
1435 Process : not null access procedure (Element : Element_Type))
1438 if Position.Node = null then
1439 raise Constraint_Error;
1442 if Position.Node.Element = null then
1443 raise Program_Error;
1446 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1447 "bad cursor in Query_Element");
1450 T : Tree_Type renames Position.Container.Tree;
1452 B : Natural renames T.Busy;
1453 L : Natural renames T.Lock;
1460 Process (Position.Node.Element.all);
1478 (Stream : access Root_Stream_Type'Class;
1479 Container : out Set)
1482 (Stream : access Root_Stream_Type'Class) return Node_Access;
1483 pragma Inline (Read_Node);
1486 new Tree_Operations.Generic_Read (Clear, Read_Node);
1493 (Stream : access Root_Stream_Type'Class) return Node_Access
1495 Node : Node_Access := new Node_Type;
1497 Node.Element := new Element_Type'(Element_Type'Input (Stream));
1501 Free (Node); -- Note that Free deallocates elem too
1505 -- Start of processing for Read
1508 Read (Stream, Container.Tree);
1512 (Stream : access Root_Stream_Type'Class;
1516 raise Program_Error;
1519 ---------------------
1520 -- Replace_Element --
1521 ---------------------
1523 procedure Replace_Element
1524 (Tree : in out Tree_Type;
1526 Item : Element_Type)
1529 if Item < Node.Element.all
1530 or else Node.Element.all < Item
1534 if Tree.Lock > 0 then
1535 raise Program_Error;
1539 X : Element_Access := Node.Element;
1541 Node.Element := new Element_Type'(Item);
1548 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
1550 Insert_New_Item : declare
1551 function New_Node return Node_Access;
1552 pragma Inline (New_Node);
1554 procedure Insert_Post is
1555 new Element_Keys.Generic_Insert_Post (New_Node);
1557 procedure Unconditional_Insert is
1558 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1564 function New_Node return Node_Access is
1566 Node.Element := new Element_Type'(Item); -- OK if fails
1567 Node.Color := Red_Black_Trees.Red;
1568 Node.Parent := null;
1575 Result : Node_Access;
1577 X : Element_Access := Node.Element;
1579 -- Start of processing for Insert_New_Item
1582 Unconditional_Insert
1586 pragma Assert (Result = Node);
1588 Free_Element (X); -- OK if fails
1589 end Insert_New_Item;
1590 end Replace_Element;
1592 procedure Replace_Element
1593 (Container : in out Set;
1595 New_Item : Element_Type)
1598 if Position.Node = null then
1599 raise Constraint_Error;
1602 if Position.Node.Element = null then
1603 raise Program_Error;
1606 if Position.Container /= Container'Unrestricted_Access then
1607 raise Program_Error;
1610 pragma Assert (Vet (Container.Tree, Position.Node),
1611 "bad cursor in Replace_Element");
1613 Replace_Element (Container.Tree, Position.Node, New_Item);
1614 end Replace_Element;
1616 ---------------------
1617 -- Reverse_Iterate --
1618 ---------------------
1620 procedure Reverse_Iterate
1622 Item : Element_Type;
1623 Process : not null access procedure (Position : Cursor))
1625 procedure Process_Node (Node : Node_Access);
1626 pragma Inline (Process_Node);
1628 procedure Local_Reverse_Iterate is
1629 new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1635 procedure Process_Node (Node : Node_Access) is
1637 Process (Cursor'(Container'Unrestricted_Access, Node));
1640 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1641 B : Natural renames T.Busy;
1643 -- Start of processing for Reverse_Iterate
1649 Local_Reverse_Iterate (T, Item);
1657 end Reverse_Iterate;
1659 procedure Reverse_Iterate
1661 Process : not null access procedure (Position : Cursor))
1663 procedure Process_Node (Node : Node_Access);
1664 pragma Inline (Process_Node);
1666 procedure Local_Reverse_Iterate is
1667 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1673 procedure Process_Node (Node : Node_Access) is
1675 Process (Cursor'(Container'Unrestricted_Access, Node));
1678 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1679 B : Natural renames T.Busy;
1681 -- Start of processing for Reverse_Iterate
1687 Local_Reverse_Iterate (T);
1695 end Reverse_Iterate;
1701 function Right (Node : Node_Access) return Node_Access is
1710 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1712 Node.Color := Color;
1719 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1728 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1730 Node.Parent := Parent;
1737 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1739 Node.Right := Right;
1742 --------------------------
1743 -- Symmetric_Difference --
1744 --------------------------
1746 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1748 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1749 end Symmetric_Difference;
1751 function Symmetric_Difference (Left, Right : Set) return Set is
1752 Tree : constant Tree_Type :=
1753 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1755 return Set'(Controlled with Tree);
1756 end Symmetric_Difference;
1762 function To_Set (New_Item : Element_Type) return Set is
1767 Insert_Sans_Hint (Tree, New_Item, Node);
1768 return Set'(Controlled with Tree);
1775 procedure Union (Target : in out Set; Source : Set) is
1777 Set_Ops.Union (Target.Tree, Source.Tree);
1780 function Union (Left, Right : Set) return Set is
1781 Tree : constant Tree_Type :=
1782 Set_Ops.Union (Left.Tree, Right.Tree);
1784 return Set'(Controlled with Tree);
1792 (Stream : access Root_Stream_Type'Class;
1795 procedure Write_Node
1796 (Stream : access Root_Stream_Type'Class;
1797 Node : Node_Access);
1798 pragma Inline (Write_Node);
1801 new Tree_Operations.Generic_Write (Write_Node);
1807 procedure Write_Node
1808 (Stream : access Root_Stream_Type'Class;
1812 Element_Type'Output (Stream, Node.Element.all);
1815 -- Start of processing for Write
1818 Write (Stream, Container.Tree);
1822 (Stream : access Root_Stream_Type'Class;
1826 raise Program_Error;
1829 end Ada.Containers.Indefinite_Ordered_Multisets;