1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.ORDERED_MULTISETS --
9 -- Copyright (C) 2004 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, 59 Temple Place - Suite 330, Boston, --
24 -- MA 02111-1307, 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 with System; use type System.Address;
49 package body Ada.Containers.Ordered_Multisets is
53 type Node_Type is limited record
57 Color : Red_Black_Trees.Color_Type := Red;
58 Element : Element_Type;
61 -----------------------------
62 -- Node Access Subprograms --
63 -----------------------------
65 -- These subprograms provide a functional interface to access fields
66 -- of a node, and a procedural interface for modifying these values.
68 function Color (Node : Node_Access) return Color_Type;
69 pragma Inline (Color);
71 function Left (Node : Node_Access) return Node_Access;
74 function Parent (Node : Node_Access) return Node_Access;
75 pragma Inline (Parent);
77 function Right (Node : Node_Access) return Node_Access;
78 pragma Inline (Right);
80 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
81 pragma Inline (Set_Parent);
83 procedure Set_Left (Node : Node_Access; Left : Node_Access);
84 pragma Inline (Set_Left);
86 procedure Set_Right (Node : Node_Access; Right : Node_Access);
87 pragma Inline (Set_Right);
89 procedure Set_Color (Node : Node_Access; Color : Color_Type);
90 pragma Inline (Set_Color);
92 -----------------------
93 -- Local Subprograms --
94 -----------------------
96 function Copy_Node (Source : Node_Access) return Node_Access;
97 pragma Inline (Copy_Node);
99 function Copy_Tree (Source_Root : Node_Access) return Node_Access;
101 procedure Delete_Tree (X : in out Node_Access);
103 procedure Insert_With_Hint
104 (Dst_Tree : in out Tree_Type;
105 Dst_Hint : Node_Access;
106 Src_Node : Node_Access;
107 Dst_Node : out Node_Access);
109 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
110 pragma Inline (Is_Equal_Node_Node);
112 function Is_Greater_Element_Node
113 (Left : Element_Type;
114 Right : Node_Access) return Boolean;
115 pragma Inline (Is_Greater_Element_Node);
117 function Is_Less_Element_Node
118 (Left : Element_Type;
119 Right : Node_Access) return Boolean;
120 pragma Inline (Is_Less_Element_Node);
122 function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
123 pragma Inline (Is_Less_Node_Node);
125 --------------------------
126 -- Local Instantiations --
127 --------------------------
129 package Tree_Operations is
130 new Red_Black_Trees.Generic_Operations
131 (Tree_Types => Tree_Types,
132 Null_Node => Node_Access'(null));
137 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
140 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
142 package Element_Keys is
143 new Red_Black_Trees.Generic_Keys
144 (Tree_Operations => Tree_Operations,
145 Key_Type => Element_Type,
146 Is_Less_Key_Node => Is_Less_Element_Node,
147 Is_Greater_Key_Node => Is_Greater_Element_Node);
150 new Generic_Set_Operations
151 (Tree_Operations => Tree_Operations,
152 Insert_With_Hint => Insert_With_Hint,
153 Copy_Tree => Copy_Tree,
154 Delete_Tree => Delete_Tree,
155 Is_Less => Is_Less_Node_Node,
162 function "<" (Left, Right : Cursor) return Boolean is
164 return Left.Node.Element < Right.Node.Element;
167 function "<" (Left : Cursor; Right : Element_Type)
170 return Left.Node.Element < Right;
173 function "<" (Left : Element_Type; Right : Cursor)
176 return Left < Right.Node.Element;
183 function "=" (Left, Right : Set) return Boolean is
185 if Left'Address = Right'Address then
189 return Is_Equal (Left.Tree, Right.Tree);
196 function ">" (Left, Right : Cursor) return Boolean is
198 -- L > R same as R < L
200 return Right.Node.Element < Left.Node.Element;
203 function ">" (Left : Cursor; Right : Element_Type)
206 return Right < Left.Node.Element;
209 function ">" (Left : Element_Type; Right : Cursor)
212 return Right.Node.Element < Left;
219 procedure Adjust (Container : in out Set) is
220 Tree : Tree_Type renames Container.Tree;
222 N : constant Count_Type := Tree.Length;
223 X : constant Node_Access := Tree.Root;
227 pragma Assert (X = null);
231 Tree := (Length => 0, others => null);
233 Tree.Root := Copy_Tree (X);
234 Tree.First := Min (Tree.Root);
235 Tree.Last := Max (Tree.Root);
243 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
244 Node : constant Node_Access :=
245 Element_Keys.Ceiling (Container.Tree, Item);
252 return Cursor'(Container'Unchecked_Access, Node);
259 procedure Clear (Container : in out Set) is
260 Tree : Tree_Type renames Container.Tree;
261 Root : Node_Access := Tree.Root;
263 Tree := (Length => 0, others => null);
271 function Color (Node : Node_Access) return Color_Type is
280 function Contains (Container : Set; Item : Element_Type) return Boolean is
282 return Find (Container, Item) /= No_Element;
289 function Copy_Node (Source : Node_Access) return Node_Access is
290 Target : constant Node_Access :=
291 new Node_Type'(Parent => null,
294 Color => Source.Color,
295 Element => Source.Element);
304 function Copy_Tree (Source_Root : Node_Access) return Node_Access is
305 Target_Root : Node_Access := Copy_Node (Source_Root);
310 if Source_Root.Right /= null then
311 Target_Root.Right := Copy_Tree (Source_Root.Right);
312 Target_Root.Right.Parent := Target_Root;
316 X := Source_Root.Left;
319 Y : Node_Access := Copy_Node (X);
325 if X.Right /= null then
326 Y.Right := Copy_Tree (X.Right);
339 Delete_Tree (Target_Root);
347 procedure Delete (Container : in out Set; Item : Element_Type) is
348 Tree : Tree_Type renames Container.Tree;
349 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
350 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
355 raise Constraint_Error;
360 Node := Tree_Operations.Next (Node);
361 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
364 exit when Node = Done;
368 procedure Delete (Container : in out Set; Position : in out Cursor) is
370 if Position = No_Element then
374 if Position.Container /= Set_Access'(Container'Unchecked_Access) then
378 Delete_Node_Sans_Free (Container.Tree, Position.Node);
379 Free (Position.Node);
381 Position.Container := null;
388 procedure Delete_First (Container : in out Set) is
389 Tree : Tree_Type renames Container.Tree;
390 X : Node_Access := Tree.First;
397 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
405 procedure Delete_Last (Container : in out Set) is
406 Tree : Tree_Type renames Container.Tree;
407 X : Node_Access := Tree.Last;
414 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
422 procedure Delete_Tree (X : in out Node_Access) is
438 procedure Difference (Target : in out Set; Source : Set) is
440 if Target'Address = Source'Address then
445 Set_Ops.Difference (Target.Tree, Source.Tree);
448 function Difference (Left, Right : Set) return Set is
450 if Left'Address = Right'Address then
455 Tree : constant Tree_Type :=
456 Set_Ops.Difference (Left.Tree, Right.Tree);
458 return (Controlled with Tree);
466 function Element (Position : Cursor) return Element_Type is
468 return Position.Node.Element;
475 procedure Exclude (Container : in out Set; Item : Element_Type) is
476 Tree : Tree_Type renames Container.Tree;
477 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
478 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
481 while Node /= Done loop
483 Node := Tree_Operations.Next (Node);
484 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
493 function Find (Container : Set; Item : Element_Type) return Cursor is
494 Node : constant Node_Access :=
495 Element_Keys.Find (Container.Tree, Item);
502 return Cursor'(Container'Unchecked_Access, Node);
509 function First (Container : Set) return Cursor is
511 if Container.Tree.First = null then
515 return Cursor'(Container'Unchecked_Access, Container.Tree.First);
522 function First_Element (Container : Set) return Element_Type is
524 return Container.Tree.First.Element;
531 function Floor (Container : Set; Item : Element_Type) return Cursor is
532 Node : constant Node_Access :=
533 Element_Keys.Floor (Container.Tree, Item);
540 return Cursor'(Container'Unchecked_Access, Node);
547 package body Generic_Keys is
549 -----------------------
550 -- Local Subprograms --
551 -----------------------
553 function Is_Greater_Key_Node
555 Right : Node_Access) return Boolean;
556 pragma Inline (Is_Greater_Key_Node);
558 function Is_Less_Key_Node
560 Right : Node_Access) return Boolean;
561 pragma Inline (Is_Less_Key_Node);
563 --------------------------
564 -- Local_Instantiations --
565 --------------------------
568 new Red_Black_Trees.Generic_Keys
569 (Tree_Operations => Tree_Operations,
570 Key_Type => Key_Type,
571 Is_Less_Key_Node => Is_Less_Key_Node,
572 Is_Greater_Key_Node => Is_Greater_Key_Node);
578 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
580 return Left < Right.Node.Element;
583 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
585 return Right > Left.Node.Element;
592 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
594 return Right < Left.Node.Element;
597 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
599 return Left > Right.Node.Element;
606 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
607 Node : constant Node_Access :=
608 Key_Keys.Ceiling (Container.Tree, Key);
615 return Cursor'(Container'Unchecked_Access, Node);
618 ----------------------------
619 -- Checked_Update_Element --
620 ----------------------------
622 procedure Checked_Update_Element
623 (Container : in out Set;
625 Process : not null access procedure (Element : in out Element_Type))
628 if Position.Container = null then
629 raise Constraint_Error;
632 if Position.Container /= Set_Access'(Container'Unchecked_Access) then
637 Old_Key : Key_Type renames Key (Position.Node.Element);
640 Process (Position.Node.Element);
642 if Old_Key < Position.Node.Element
643 or else Old_Key > Position.Node.Element
651 Delete_Node_Sans_Free (Container.Tree, Position.Node);
654 Result : Node_Access;
656 function New_Node return Node_Access;
657 pragma Inline (New_Node);
659 procedure Insert_Post is
660 new Key_Keys.Generic_Insert_Post (New_Node);
663 new Key_Keys.Generic_Unconditional_Insert (Insert_Post);
669 function New_Node return Node_Access is
671 return Position.Node;
674 -- Start of processing for Do_Insert
678 (Tree => Container.Tree,
679 Key => Key (Position.Node.Element),
682 pragma Assert (Result = Position.Node);
684 end Checked_Update_Element;
690 function Contains (Container : Set; Key : Key_Type) return Boolean is
692 return Find (Container, Key) /= No_Element;
699 procedure Delete (Container : in out Set; Key : Key_Type) is
700 Tree : Tree_Type renames Container.Tree;
701 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
702 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
707 raise Constraint_Error;
712 Node := Tree_Operations.Next (Node);
713 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
716 exit when Node = Done;
724 function Element (Container : Set; Key : Key_Type) return Element_Type is
725 Node : constant Node_Access :=
726 Key_Keys.Find (Container.Tree, Key);
735 procedure Exclude (Container : in out Set; Key : Key_Type) is
736 Tree : Tree_Type renames Container.Tree;
737 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
738 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
741 while Node /= Done loop
743 Node := Tree_Operations.Next (Node);
744 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
753 function Find (Container : Set; Key : Key_Type) return Cursor is
754 Node : constant Node_Access :=
755 Key_Keys.Find (Container.Tree, Key);
762 return Cursor'(Container'Unchecked_Access, Node);
769 function Floor (Container : Set; Key : Key_Type) return Cursor is
770 Node : constant Node_Access :=
771 Key_Keys.Floor (Container.Tree, Key);
778 return Cursor'(Container'Unchecked_Access, Node);
781 -------------------------
782 -- Is_Greater_Key_Node --
783 -------------------------
785 function Is_Greater_Key_Node
787 Right : Node_Access) return Boolean is
789 return Left > Right.Element;
790 end Is_Greater_Key_Node;
792 ----------------------
793 -- Is_Less_Key_Node --
794 ----------------------
796 function Is_Less_Key_Node
798 Right : Node_Access) return Boolean is
800 return Left < Right.Element;
801 end Is_Less_Key_Node;
810 Process : not null access procedure (Position : Cursor))
812 procedure Process_Node (Node : Node_Access);
813 pragma Inline (Process_Node);
815 procedure Local_Iterate is
816 new Key_Keys.Generic_Iteration (Process_Node);
822 procedure Process_Node (Node : Node_Access) is
824 Process (Cursor'(Container'Unchecked_Access, Node));
827 -- Start of processing for Iterate
830 Local_Iterate (Container.Tree, Key);
837 function Key (Position : Cursor) return Key_Type is
839 return Key (Position.Node.Element);
846 -- In post-madision api:???
849 -- (Container : in out Set;
851 -- New_Item : Element_Type)
853 -- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
856 -- if Node = null then
857 -- raise Constraint_Error;
860 -- Replace_Node (Container, Node, New_Item);
863 ---------------------
864 -- Reverse_Iterate --
865 ---------------------
867 procedure Reverse_Iterate
870 Process : not null access procedure (Position : Cursor))
872 procedure Process_Node (Node : Node_Access);
873 pragma Inline (Process_Node);
875 procedure Local_Reverse_Iterate is
876 new Key_Keys.Generic_Reverse_Iteration (Process_Node);
882 procedure Process_Node (Node : Node_Access) is
884 Process (Cursor'(Container'Unchecked_Access, Node));
887 -- Start of processing for Reverse_Iterate
890 Local_Reverse_Iterate (Container.Tree, Key);
899 function Has_Element (Position : Cursor) return Boolean is
901 return Position /= No_Element;
908 procedure Insert (Container : in out Set; New_Item : Element_Type) is
911 Insert (Container, New_Item, Position);
915 (Container : in out Set;
916 New_Item : Element_Type;
917 Position : out Cursor)
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 Unconditional_Insert_Sans_Hint is
926 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
932 function New_Node return Node_Access is
933 Node : constant Node_Access :=
934 new Node_Type'(Parent => null,
938 Element => New_Item);
943 -- Start of processing for Insert
946 Unconditional_Insert_Sans_Hint
951 Position.Container := Container'Unchecked_Access;
954 ----------------------
955 -- Insert_With_Hint --
956 ----------------------
958 procedure Insert_With_Hint
959 (Dst_Tree : in out Tree_Type;
960 Dst_Hint : Node_Access;
961 Src_Node : Node_Access;
962 Dst_Node : out Node_Access)
964 function New_Node return Node_Access;
965 pragma Inline (New_Node);
967 procedure Insert_Post is
968 new Element_Keys.Generic_Insert_Post (New_Node);
970 procedure Insert_Sans_Hint is
971 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
973 procedure Local_Insert_With_Hint is
974 new Element_Keys.Generic_Unconditional_Insert_With_Hint
982 function New_Node return Node_Access is
983 Node : constant Node_Access :=
984 new Node_Type'(Parent => null,
988 Element => Src_Node.Element);
993 -- Start of processing for Insert_With_Hint
996 Local_Insert_With_Hint
1001 end Insert_With_Hint;
1007 procedure Intersection (Target : in out Set; Source : Set) is
1009 if Target'Address = Source'Address then
1013 Set_Ops.Intersection (Target.Tree, Source.Tree);
1016 function Intersection (Left, Right : Set) return Set is
1018 if Left'Address = Right'Address then
1023 Tree : constant Tree_Type :=
1024 Set_Ops.Intersection (Left.Tree, Right.Tree);
1026 return (Controlled with Tree);
1034 function Is_Empty (Container : Set) return Boolean is
1036 return Container.Tree.Length = 0;
1039 ------------------------
1040 -- Is_Equal_Node_Node --
1041 ------------------------
1043 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1045 return L.Element = R.Element;
1046 end Is_Equal_Node_Node;
1048 -----------------------------
1049 -- Is_Greater_Element_Node --
1050 -----------------------------
1052 function Is_Greater_Element_Node
1053 (Left : Element_Type;
1054 Right : Node_Access) return Boolean
1057 -- e > node same as node < e
1059 return Right.Element < Left;
1060 end Is_Greater_Element_Node;
1062 --------------------------
1063 -- Is_Less_Element_Node --
1064 --------------------------
1066 function Is_Less_Element_Node
1067 (Left : Element_Type;
1068 Right : Node_Access) return Boolean
1071 return Left < Right.Element;
1072 end Is_Less_Element_Node;
1074 -----------------------
1075 -- Is_Less_Node_Node --
1076 -----------------------
1078 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1080 return L.Element < R.Element;
1081 end Is_Less_Node_Node;
1087 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1089 if Subset'Address = Of_Set'Address then
1093 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1102 Process : not null access procedure (Position : Cursor))
1104 procedure Process_Node (Node : Node_Access);
1105 pragma Inline (Process_Node);
1107 procedure Local_Iterate is
1108 new Tree_Operations.Generic_Iteration (Process_Node);
1114 procedure Process_Node (Node : Node_Access) is
1116 Process (Cursor'(Container'Unchecked_Access, Node));
1119 -- Start of processing for Iterate
1122 Local_Iterate (Container.Tree);
1127 Item : Element_Type;
1128 Process : not null access procedure (Position : Cursor))
1130 procedure Process_Node (Node : Node_Access);
1131 pragma Inline (Process_Node);
1133 procedure Local_Iterate is
1134 new Element_Keys.Generic_Iteration (Process_Node);
1140 procedure Process_Node (Node : Node_Access) is
1142 Process (Cursor'(Container'Unchecked_Access, Node));
1145 -- Start of processing for Iterate
1148 Local_Iterate (Container.Tree, Item);
1155 function Last (Container : Set) return Cursor is
1157 if Container.Tree.Last = null then
1161 return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
1168 function Last_Element (Container : Set) return Element_Type is
1170 return Container.Tree.Last.Element;
1177 function Left (Node : Node_Access) return Node_Access is
1186 function Length (Container : Set) return Count_Type is
1188 return Container.Tree.Length;
1195 procedure Move (Target : in out Set; Source : in out Set) is
1197 if Target'Address = Source'Address then
1201 Move (Target => Target.Tree, Source => Source.Tree);
1208 procedure Next (Position : in out Cursor)
1211 Position := Next (Position);
1214 function Next (Position : Cursor) return Cursor is
1216 if Position = No_Element then
1221 Node : constant Node_Access :=
1222 Tree_Operations.Next (Position.Node);
1228 return Cursor'(Position.Container, Node);
1236 function Overlap (Left, Right : Set) return Boolean is
1238 if Left'Address = Right'Address then
1239 return Left.Tree.Length /= 0;
1242 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1249 function Parent (Node : Node_Access) return Node_Access is
1258 procedure Previous (Position : in out Cursor)
1261 Position := Previous (Position);
1264 function Previous (Position : Cursor) return Cursor is
1266 if Position = No_Element then
1271 Node : constant Node_Access :=
1272 Tree_Operations.Previous (Position.Node);
1278 return Cursor'(Position.Container, Node);
1286 procedure Query_Element
1288 Process : not null access procedure (Element : Element_Type))
1291 Process (Position.Node.Element);
1299 (Stream : access Root_Stream_Type'Class;
1300 Container : out Set)
1302 N : Count_Type'Base;
1304 function New_Node return Node_Access;
1305 pragma Inline (New_Node);
1307 procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
1313 function New_Node return Node_Access is
1314 Node : Node_Access := new Node_Type;
1318 Element_Type'Read (Stream, Node.Element);
1329 -- Start of processing for Read
1334 Count_Type'Base'Read (Stream, N);
1335 pragma Assert (N >= 0);
1337 Local_Read (Container.Tree, N);
1344 -- NOTE: from post-madison api ???
1346 -- procedure Replace
1347 -- (Container : in out Set;
1348 -- Position : Cursor;
1349 -- By : Element_Type)
1352 -- if Position.Container = null then
1353 -- raise Constraint_Error;
1356 -- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
1357 -- raise Program_Error;
1360 -- Replace_Node (Container, Position.Node, By);
1367 -- NOTE: from post-madison api ???
1369 -- procedure Replace_Node
1370 -- (Container : in out Set;
1371 -- Position : Node_Access;
1372 -- By : Element_Type)
1374 -- Tree : Tree_Type renames Container.Tree;
1375 -- Node : Node_Access := Position;
1378 -- if By < Node.Element
1379 -- or else Node.Element < By
1385 -- Node.Element := By;
1389 -- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
1397 -- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
1400 -- Node.Element := By;
1408 -- Do_Insert : declare
1409 -- Result : Node_Access;
1410 -- Success : Boolean;
1412 -- function New_Node return Node_Access;
1413 -- pragma Inline (New_Node);
1415 -- procedure Insert_Post is
1416 -- new Element_Keys.Generic_Insert_Post (New_Node);
1418 -- procedure Insert is
1419 -- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1425 -- function New_Node return Node_Access is
1430 -- -- Start of processing for Do_Insert
1435 -- Key => Node.Element,
1437 -- Success => Success);
1439 -- if not Success then
1441 -- raise Program_Error;
1444 -- pragma Assert (Result = Node);
1446 -- end Replace_Node;
1448 ---------------------
1449 -- Reverse_Iterate --
1450 ---------------------
1452 procedure Reverse_Iterate
1454 Process : not null access procedure (Position : Cursor))
1456 procedure Process_Node (Node : Node_Access);
1457 pragma Inline (Process_Node);
1459 procedure Local_Reverse_Iterate is
1460 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1466 procedure Process_Node (Node : Node_Access) is
1468 Process (Cursor'(Container'Unchecked_Access, Node));
1471 -- Start of processing for Reverse_Iterate
1474 Local_Reverse_Iterate (Container.Tree);
1475 end Reverse_Iterate;
1477 procedure Reverse_Iterate
1479 Item : Element_Type;
1480 Process : not null access procedure (Position : Cursor))
1482 procedure Process_Node (Node : Node_Access);
1483 pragma Inline (Process_Node);
1485 procedure Local_Reverse_Iterate is
1486 new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1492 procedure Process_Node (Node : Node_Access) is
1494 Process (Cursor'(Container'Unchecked_Access, Node));
1497 -- Start of processing for Reverse_Iterate
1500 Local_Reverse_Iterate (Container.Tree, Item);
1501 end Reverse_Iterate;
1507 function Right (Node : Node_Access) return Node_Access is
1516 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1518 Node.Color := Color;
1525 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1534 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1536 Node.Parent := Parent;
1543 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1545 Node.Right := Right;
1548 --------------------------
1549 -- Symmetric_Difference --
1550 --------------------------
1552 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1554 if Target'Address = Source'Address then
1559 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1560 end Symmetric_Difference;
1562 function Symmetric_Difference (Left, Right : Set) return Set is
1564 if Left'Address = Right'Address then
1569 Tree : constant Tree_Type :=
1570 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1572 return (Controlled with Tree);
1574 end Symmetric_Difference;
1580 procedure Union (Target : in out Set; Source : Set) is
1582 if Target'Address = Source'Address then
1586 Set_Ops.Union (Target.Tree, Source.Tree);
1589 function Union (Left, Right : Set) return Set is
1591 if Left'Address = Right'Address then
1596 Tree : constant Tree_Type :=
1597 Set_Ops.Union (Left.Tree, Right.Tree);
1599 return (Controlled with Tree);
1608 (Stream : access Root_Stream_Type'Class;
1611 procedure Process (Node : Node_Access);
1612 pragma Inline (Process);
1614 procedure Iterate is
1615 new Tree_Operations.Generic_Iteration (Process);
1621 procedure Process (Node : Node_Access) is
1623 Element_Type'Write (Stream, Node.Element);
1626 -- Start of processing for Write
1629 Count_Type'Base'Write (Stream, Container.Tree.Length);
1630 Iterate (Container.Tree);
1633 end Ada.Containers.Ordered_Multisets;