1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_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.Indefinite_Ordered_Multisets is
53 type Element_Access is access Element_Type;
55 type Node_Type is limited record
59 Color : Red_Black_Trees.Color_Type := Red;
60 Element : Element_Access;
63 -----------------------------
64 -- Node Access Subprograms --
65 -----------------------------
67 -- These subprograms provide a functional interface to access fields
68 -- of a node, and a procedural interface for modifying these values.
70 function Color (Node : Node_Access) return Color_Type;
71 pragma Inline (Color);
73 function Left (Node : Node_Access) return Node_Access;
76 function Parent (Node : Node_Access) return Node_Access;
77 pragma Inline (Parent);
79 function Right (Node : Node_Access) return Node_Access;
80 pragma Inline (Right);
82 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
83 pragma Inline (Set_Parent);
85 procedure Set_Left (Node : Node_Access; Left : Node_Access);
86 pragma Inline (Set_Left);
88 procedure Set_Right (Node : Node_Access; Right : Node_Access);
89 pragma Inline (Set_Right);
91 procedure Set_Color (Node : Node_Access; Color : Color_Type);
92 pragma Inline (Set_Color);
94 -----------------------
95 -- Local Subprograms --
96 -----------------------
98 function Copy_Node (Source : Node_Access) return Node_Access;
99 pragma Inline (Copy_Node);
101 function Copy_Tree (Source_Root : Node_Access) return Node_Access;
103 procedure Delete_Tree (X : in out Node_Access);
105 procedure Free (X : in out Node_Access);
107 procedure Insert_With_Hint
108 (Dst_Tree : in out Tree_Type;
109 Dst_Hint : Node_Access;
110 Src_Node : Node_Access;
111 Dst_Node : out Node_Access);
113 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
114 pragma Inline (Is_Equal_Node_Node);
116 function Is_Greater_Element_Node
117 (Left : Element_Type;
118 Right : Node_Access) return Boolean;
119 pragma Inline (Is_Greater_Element_Node);
121 function Is_Less_Element_Node
122 (Left : Element_Type;
123 Right : Node_Access) return Boolean;
124 pragma Inline (Is_Less_Element_Node);
126 function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
127 pragma Inline (Is_Less_Node_Node);
129 --------------------------
130 -- Local Instantiations --
131 --------------------------
133 package Tree_Operations is
134 new Red_Black_Trees.Generic_Operations
135 (Tree_Types => Tree_Types,
136 Null_Node => Node_Access'(null));
140 procedure Free_Element is
141 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
144 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
147 new Generic_Set_Operations
148 (Tree_Operations => Tree_Operations,
149 Insert_With_Hint => Insert_With_Hint,
150 Copy_Tree => Copy_Tree,
151 Delete_Tree => Delete_Tree,
152 Is_Less => Is_Less_Node_Node,
155 package Element_Keys is
156 new Red_Black_Trees.Generic_Keys
157 (Tree_Operations => Tree_Operations,
158 Key_Type => Element_Type,
159 Is_Less_Key_Node => Is_Less_Element_Node,
160 Is_Greater_Key_Node => Is_Greater_Element_Node);
166 function "<" (Left, Right : Cursor) return Boolean is
168 return Left.Node.Element.all < Right.Node.Element.all;
171 function "<" (Left : Cursor; Right : Element_Type) return Boolean is
173 return Left.Node.Element.all < Right;
176 function "<" (Left : Element_Type; Right : Cursor) return Boolean is
178 return Left < Right.Node.Element.all;
185 function "=" (Left, Right : Set) return Boolean is begin
186 if Left'Address = Right'Address then
190 return Is_Equal (Left.Tree, Right.Tree);
197 function ">" (Left : Cursor; Right : Element_Type) return Boolean is
199 return Right < Left.Node.Element.all;
202 function ">" (Left, Right : Cursor) return Boolean is
204 -- L > R same as R < L
206 return Right.Node.Element.all < Left.Node.Element.all;
209 function ">" (Left : Element_Type; Right : Cursor) return Boolean is
211 return Right.Node.Element.all < Left;
218 procedure Adjust (Container : in out Set) is
219 Tree : Tree_Type renames Container.Tree;
221 N : constant Count_Type := Tree.Length;
222 X : constant Node_Access := Tree.Root;
226 pragma Assert (X = null);
230 Tree := (Length => 0, others => null);
232 Tree.Root := Copy_Tree (X);
233 Tree.First := Min (Tree.Root);
234 Tree.Last := Max (Tree.Root);
242 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
243 Node : constant Node_Access :=
244 Element_Keys.Ceiling (Container.Tree, Item);
251 return Cursor'(Container'Unchecked_Access, Node);
258 procedure Clear (Container : in out Set) is
259 Tree : Tree_Type renames Container.Tree;
260 Root : Node_Access := Tree.Root;
262 Tree := (Length => 0, others => null);
270 function Color (Node : Node_Access) return Color_Type is
279 function Contains (Container : Set; Item : Element_Type) return Boolean is
281 return Find (Container, Item) /= No_Element;
288 function Copy_Node (Source : Node_Access) return Node_Access is
289 X : Element_Access := new Element_Type'(Source.Element.all);
292 return new Node_Type'(Parent => null,
295 Color => Source.Color,
308 function Copy_Tree (Source_Root : Node_Access) return Node_Access is
309 Target_Root : Node_Access := Copy_Node (Source_Root);
314 if Source_Root.Right /= null then
315 Target_Root.Right := Copy_Tree (Source_Root.Right);
316 Target_Root.Right.Parent := Target_Root;
320 X := Source_Root.Left;
323 Y : Node_Access := Copy_Node (X);
329 if X.Right /= null then
330 Y.Right := Copy_Tree (X.Right);
343 Delete_Tree (Target_Root);
351 procedure Delete (Container : in out Set; Item : Element_Type) is
352 Tree : Tree_Type renames Container.Tree;
353 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
354 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
359 raise Constraint_Error;
364 Node := Tree_Operations.Next (Node);
365 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
368 exit when Node = Done;
372 procedure Delete (Container : in out Set; Position : in out Cursor) is
374 if Position = No_Element then
378 if Position.Container /= Set_Access'(Container'Unchecked_Access) then
382 Delete_Node_Sans_Free (Container.Tree, Position.Node);
383 Free (Position.Node);
385 Position.Container := null;
392 procedure Delete_First (Container : in out Set) is
393 Tree : Tree_Type renames Container.Tree;
394 X : Node_Access := Tree.First;
401 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
409 procedure Delete_Last (Container : in out Set) is
410 Tree : Tree_Type renames Container.Tree;
411 X : Node_Access := Tree.Last;
418 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
426 procedure Delete_Tree (X : in out Node_Access) is
442 procedure Difference (Target : in out Set; Source : Set) is
444 if Target'Address = Source'Address then
449 Set_Ops.Difference (Target.Tree, Source.Tree);
452 function Difference (Left, Right : Set) return Set is
454 if Left'Address = Right'Address then
459 Tree : constant Tree_Type :=
460 Set_Ops.Difference (Left.Tree, Right.Tree);
462 return (Controlled with Tree);
470 function Element (Position : Cursor) return Element_Type is
472 return Position.Node.Element.all;
479 procedure Exclude (Container : in out Set; Item : Element_Type) is
480 Tree : Tree_Type renames Container.Tree;
481 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
482 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
485 while Node /= Done loop
487 Node := Tree_Operations.Next (Node);
488 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
497 function Find (Container : Set; Item : Element_Type) return Cursor is
498 Node : constant Node_Access :=
499 Element_Keys.Find (Container.Tree, Item);
506 return Cursor'(Container'Unchecked_Access, Node);
513 function First (Container : Set) return Cursor is
515 if Container.Tree.First = null then
519 return Cursor'(Container'Unchecked_Access, Container.Tree.First);
526 function First_Element (Container : Set) return Element_Type is
528 return Container.Tree.First.Element.all;
535 function Floor (Container : Set; Item : Element_Type) return Cursor is
536 Node : constant Node_Access :=
537 Element_Keys.Floor (Container.Tree, Item);
544 return Cursor'(Container'Unchecked_Access, Node);
551 procedure Free (X : in out Node_Access) is
552 procedure Deallocate is
553 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
556 Free_Element (X.Element);
565 package body Generic_Keys is
567 -----------------------
568 -- Local Subprograms --
569 -----------------------
571 function Is_Less_Key_Node
573 Right : Node_Access) return Boolean;
574 pragma Inline (Is_Less_Key_Node);
576 function Is_Greater_Key_Node
578 Right : Node_Access) return Boolean;
579 pragma Inline (Is_Greater_Key_Node);
581 --------------------------
582 -- Local Instantiations --
583 --------------------------
586 new Red_Black_Trees.Generic_Keys
587 (Tree_Operations => Tree_Operations,
588 Key_Type => Key_Type,
589 Is_Less_Key_Node => Is_Less_Key_Node,
590 Is_Greater_Key_Node => Is_Greater_Key_Node);
596 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
598 return Left < Right.Node.Element.all;
601 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
603 return Right > Left.Node.Element.all;
610 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
612 return Left > Right.Node.Element.all;
615 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
617 return Right < Left.Node.Element.all;
624 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
625 Node : constant Node_Access :=
626 Key_Keys.Ceiling (Container.Tree, Key);
633 return Cursor'(Container'Unchecked_Access, Node);
636 ----------------------------
637 -- Checked_Update_Element --
638 ----------------------------
640 procedure Checked_Update_Element
641 (Container : in out Set;
643 Process : not null access procedure (Element : in out Element_Type))
646 if Position.Container = null then
647 raise Constraint_Error;
650 if Position.Container /= Set_Access'(Container'Unchecked_Access) then
655 Old_Key : Key_Type renames Key (Position.Node.Element.all);
658 Process (Position.Node.Element.all);
660 if Old_Key < Position.Node.Element.all
661 or else Old_Key > Position.Node.Element.all
669 Delete_Node_Sans_Free (Container.Tree, Position.Node);
672 Result : Node_Access;
674 function New_Node return Node_Access;
675 pragma Inline (New_Node);
677 procedure Insert_Post is
678 new Key_Keys.Generic_Insert_Post (New_Node);
681 new Key_Keys.Generic_Unconditional_Insert (Insert_Post);
687 function New_Node return Node_Access is
689 return Position.Node;
692 -- Start of processing for Do_Insert
696 (Tree => Container.Tree,
697 Key => Key (Position.Node.Element.all),
700 pragma Assert (Result = Position.Node);
702 end Checked_Update_Element;
708 function Contains (Container : Set; Key : Key_Type) return Boolean is
710 return Find (Container, Key) /= No_Element;
717 procedure Delete (Container : in out Set; Key : Key_Type) is
718 Tree : Tree_Type renames Container.Tree;
719 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
720 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
725 raise Constraint_Error;
730 Node := Tree_Operations.Next (Node);
731 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
734 exit when Node = Done;
742 function Element (Container : Set; Key : Key_Type) return Element_Type is
743 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
745 return Node.Element.all;
752 procedure Exclude (Container : in out Set; Key : Key_Type) is
753 Tree : Tree_Type renames Container.Tree;
754 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
755 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
759 while Node /= Done loop
761 Node := Tree_Operations.Next (Node);
762 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
771 function Find (Container : Set; Key : Key_Type) return Cursor is
772 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
779 return Cursor'(Container'Unchecked_Access, Node);
786 function Floor (Container : Set; Key : Key_Type) return Cursor is
787 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
794 return Cursor'(Container'Unchecked_Access, Node);
797 -------------------------
798 -- Is_Greater_Key_Node --
799 -------------------------
801 function Is_Greater_Key_Node
803 Right : Node_Access) return Boolean is
805 return Left > Right.Element.all;
806 end Is_Greater_Key_Node;
808 ----------------------
809 -- Is_Less_Key_Node --
810 ----------------------
812 function Is_Less_Key_Node
814 Right : Node_Access) return Boolean is
816 return Left < Right.Element.all;
817 end Is_Less_Key_Node;
826 Process : not null access procedure (Position : Cursor))
828 procedure Process_Node (Node : Node_Access);
829 pragma Inline (Process_Node);
831 procedure Local_Iterate is
832 new Key_Keys.Generic_Iteration (Process_Node);
838 procedure Process_Node (Node : Node_Access) is
840 Process (Cursor'(Container'Unchecked_Access, Node));
843 -- Start of processing for Iterate
846 Local_Iterate (Container.Tree, Key);
853 function Key (Position : Cursor) return Key_Type is
855 return Key (Position.Node.Element.all);
862 -- In post-madision api: ???
865 -- (Container : in out Set;
867 -- New_Item : Element_Type)
869 -- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
872 -- if Node = null then
873 -- raise Constraint_Error;
876 -- Replace_Node (Container, Node, New_Item);
879 ---------------------
880 -- Reverse_Iterate --
881 ---------------------
883 procedure Reverse_Iterate
886 Process : not null access procedure (Position : Cursor))
888 procedure Process_Node (Node : Node_Access);
889 pragma Inline (Process_Node);
895 procedure Local_Reverse_Iterate is
896 new Key_Keys.Generic_Reverse_Iteration (Process_Node);
902 procedure Process_Node (Node : Node_Access) is
904 Process (Cursor'(Container'Unchecked_Access, Node));
907 -- Start of processing for Reverse_Iterate
910 Local_Reverse_Iterate (Container.Tree, Key);
919 function Has_Element (Position : Cursor) return Boolean is
921 return Position /= No_Element;
928 procedure Insert (Container : in out Set; New_Item : Element_Type) is
931 Insert (Container, New_Item, Position);
935 (Container : in out Set;
936 New_Item : Element_Type;
937 Position : out Cursor)
939 function New_Node return Node_Access;
940 pragma Inline (New_Node);
942 procedure Insert_Post is
943 new Element_Keys.Generic_Insert_Post (New_Node);
945 procedure Unconditional_Insert_Sans_Hint is
946 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
952 function New_Node return Node_Access is
953 X : Element_Access := new Element_Type'(New_Item);
956 return new Node_Type'(Parent => null,
968 -- Start of processing for Insert
971 Unconditional_Insert_Sans_Hint
976 Position.Container := Container'Unchecked_Access;
979 ----------------------
980 -- Insert_With_Hint --
981 ----------------------
983 procedure Insert_With_Hint
984 (Dst_Tree : in out Tree_Type;
985 Dst_Hint : Node_Access;
986 Src_Node : Node_Access;
987 Dst_Node : out Node_Access)
989 function New_Node return Node_Access;
990 pragma Inline (New_Node);
992 procedure Insert_Post is
993 new Element_Keys.Generic_Insert_Post (New_Node);
995 procedure Insert_Sans_Hint is
996 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
998 procedure Local_Insert_With_Hint is
999 new Element_Keys.Generic_Unconditional_Insert_With_Hint
1007 function New_Node return Node_Access is
1008 X : Element_Access := new Element_Type'(Src_Node.Element.all);
1011 return new Node_Type'(Parent => null,
1023 -- Start of processing for Insert_With_Hint
1026 Local_Insert_With_Hint
1029 Src_Node.Element.all,
1031 end Insert_With_Hint;
1037 procedure Intersection (Target : in out Set; Source : Set) is
1039 if Target'Address = Source'Address then
1043 Set_Ops.Intersection (Target.Tree, Source.Tree);
1046 function Intersection (Left, Right : Set) return Set is
1048 if Left'Address = Right'Address then
1053 Tree : constant Tree_Type :=
1054 Set_Ops.Intersection (Left.Tree, Right.Tree);
1056 return (Controlled with Tree);
1064 function Is_Empty (Container : Set) return Boolean is
1066 return Container.Tree.Length = 0;
1069 ------------------------
1070 -- Is_Equal_Node_Node --
1071 ------------------------
1073 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1075 return L.Element.all = R.Element.all;
1076 end Is_Equal_Node_Node;
1078 -----------------------------
1079 -- Is_Greater_Element_Node --
1080 -----------------------------
1082 function Is_Greater_Element_Node
1083 (Left : Element_Type;
1084 Right : Node_Access) return Boolean
1087 -- e > node same as node < e
1089 return Right.Element.all < Left;
1090 end Is_Greater_Element_Node;
1092 --------------------------
1093 -- Is_Less_Element_Node --
1094 --------------------------
1096 function Is_Less_Element_Node
1097 (Left : Element_Type;
1098 Right : Node_Access) return Boolean
1101 return Left < Right.Element.all;
1102 end Is_Less_Element_Node;
1104 -----------------------
1105 -- Is_Less_Node_Node --
1106 -----------------------
1108 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1110 return L.Element.all < R.Element.all;
1111 end Is_Less_Node_Node;
1117 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1119 if Subset'Address = Of_Set'Address then
1123 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1132 Item : Element_Type;
1133 Process : not null access procedure (Position : Cursor))
1135 procedure Process_Node (Node : Node_Access);
1136 pragma Inline (Process_Node);
1138 procedure Local_Iterate is
1139 new Element_Keys.Generic_Iteration (Process_Node);
1145 procedure Process_Node (Node : Node_Access) is
1147 Process (Cursor'(Container'Unchecked_Access, Node));
1150 -- Start of processing for Iterate
1153 Local_Iterate (Container.Tree, Item);
1158 Process : not null access procedure (Position : Cursor))
1160 procedure Process_Node (Node : Node_Access);
1161 pragma Inline (Process_Node);
1163 procedure Local_Iterate is
1164 new Tree_Operations.Generic_Iteration (Process_Node);
1170 procedure Process_Node (Node : Node_Access) is
1172 Process (Cursor'(Container'Unchecked_Access, Node));
1175 -- Start of processing for Iterate
1178 Local_Iterate (Container.Tree);
1185 function Last (Container : Set) return Cursor is
1187 if Container.Tree.Last = null then
1191 return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
1198 function Last_Element (Container : Set) return Element_Type is
1200 return Container.Tree.Last.Element.all;
1207 function Left (Node : Node_Access) return Node_Access is
1216 function Length (Container : Set) return Count_Type is
1218 return Container.Tree.Length;
1225 procedure Move (Target : in out Set; Source : in out Set) is
1227 if Target'Address = Source'Address then
1231 Move (Target => Target.Tree, Source => Source.Tree);
1238 function Next (Position : Cursor) return Cursor is
1240 if Position = No_Element then
1245 Node : constant Node_Access :=
1246 Tree_Operations.Next (Position.Node);
1253 return Cursor'(Position.Container, Node);
1257 procedure Next (Position : in out Cursor) is
1259 Position := Next (Position);
1266 function Overlap (Left, Right : Set) return Boolean is
1268 if Left'Address = Right'Address then
1269 return Left.Tree.Length /= 0;
1272 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1279 function Parent (Node : Node_Access) return Node_Access is
1288 function Previous (Position : Cursor) return Cursor is
1290 if Position = No_Element then
1295 Node : constant Node_Access :=
1296 Tree_Operations.Previous (Position.Node);
1303 return Cursor'(Position.Container, Node);
1307 procedure Previous (Position : in out Cursor) is
1309 Position := Previous (Position);
1316 procedure Query_Element
1318 Process : not null access procedure (Element : Element_Type))
1321 Process (Position.Node.Element.all);
1329 (Stream : access Root_Stream_Type'Class;
1330 Container : out Set)
1332 N : Count_Type'Base;
1334 function New_Node return Node_Access;
1335 pragma Inline (New_Node);
1337 procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
1343 function New_Node return Node_Access is
1344 Node : Node_Access := new Node_Type;
1348 Node.Element := new Element_Type'(Element_Type'Input (Stream));
1358 -- Start of processing for Read
1363 Count_Type'Base'Read (Stream, N);
1364 pragma Assert (N >= 0);
1366 Local_Read (Container.Tree, N);
1373 -- NOTE: from post-madison api???
1375 -- procedure Replace
1376 -- (Container : in out Set;
1377 -- Position : Cursor;
1378 -- By : Element_Type)
1381 -- if Position.Container = null then
1382 -- raise Constraint_Error;
1385 -- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
1386 -- raise Program_Error;
1389 -- Replace_Node (Container, Position.Node, By);
1396 -- NOTE: from post-madison api???
1398 -- procedure Replace_Node
1399 -- (Container : in out Set;
1400 -- Position : Node_Access;
1401 -- By : Element_Type);
1403 -- Tree : Tree_Type renames Container.Tree;
1404 -- Node : Node_Access := Position;
1407 -- if By < Node.Element
1408 -- or else Node.Element < By
1414 -- Node.Element := By;
1418 -- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
1426 -- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
1429 -- Node.Element := By;
1438 -- Result : Node_Access;
1439 -- Success : Boolean;
1441 -- function New_Node return Node_Access;
1442 -- pragma Inline (New_Node);
1444 -- procedure Insert_Post is
1445 -- new Element_Keys.Generic_Insert_Post (New_Node);
1447 -- procedure Insert is
1448 -- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1454 -- function New_Node return Node_Access is
1459 -- -- Start of processing for Replace_Node
1464 -- Key => Node.Element,
1466 -- Success => Success);
1468 -- if not Success then
1470 -- raise Program_Error;
1473 -- pragma Assert (Result = Node);
1475 -- end Replace_Node;
1477 ---------------------
1478 -- Reverse_Iterate --
1479 ---------------------
1481 procedure Reverse_Iterate
1483 Item : Element_Type;
1484 Process : not null access procedure (Position : Cursor))
1486 procedure Process_Node (Node : Node_Access);
1487 pragma Inline (Process_Node);
1489 procedure Local_Reverse_Iterate is
1490 new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1496 procedure Process_Node (Node : Node_Access) is
1498 Process (Cursor'(Container'Unchecked_Access, Node));
1501 -- Start of processing for Reverse_Iterate
1504 Local_Reverse_Iterate (Container.Tree, Item);
1505 end Reverse_Iterate;
1507 procedure Reverse_Iterate
1509 Process : not null access procedure (Position : Cursor))
1511 procedure Process_Node (Node : Node_Access);
1512 pragma Inline (Process_Node);
1514 procedure Local_Reverse_Iterate is
1515 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1521 procedure Process_Node (Node : Node_Access) is
1523 Process (Cursor'(Container'Unchecked_Access, Node));
1526 -- Start of processing for Reverse_Iterate
1529 Local_Reverse_Iterate (Container.Tree);
1530 end Reverse_Iterate;
1536 function Right (Node : Node_Access) return Node_Access is
1545 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1547 Node.Color := Color;
1554 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1563 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1565 Node.Parent := Parent;
1572 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1574 Node.Right := Right;
1577 --------------------------
1578 -- Symmetric_Difference --
1579 --------------------------
1581 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1583 if Target'Address = Source'Address then
1588 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1589 end Symmetric_Difference;
1591 function Symmetric_Difference (Left, Right : Set) return Set is
1593 if Left'Address = Right'Address then
1598 Tree : constant Tree_Type :=
1599 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1601 return (Controlled with Tree);
1603 end Symmetric_Difference;
1609 procedure Union (Target : in out Set; Source : Set) is
1611 if Target'Address = Source'Address then
1615 Set_Ops.Union (Target.Tree, Source.Tree);
1618 function Union (Left, Right : Set) return Set is begin
1619 if Left'Address = Right'Address then
1624 Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
1626 return (Controlled with Tree);
1635 (Stream : access Root_Stream_Type'Class;
1638 procedure Process (Node : Node_Access);
1639 pragma Inline (Process);
1641 procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
1647 procedure Process (Node : Node_Access) is
1649 Element_Type'Output (Stream, Node.Element.all);
1652 -- Start of processing for Write
1655 Count_Type'Base'Write (Stream, Container.Tree.Length);
1656 Iterate (Container.Tree);
1659 end Ada.Containers.Indefinite_Ordered_Multisets;