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-2006, 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
165 if Left.Node = null then
166 raise Constraint_Error with "Left cursor equals No_Element";
169 if Right.Node = null then
170 raise Constraint_Error with "Right cursor equals No_Element";
173 if Left.Node.Element = null then
174 raise Program_Error with "Left cursor is bad";
177 if Right.Node.Element = null then
178 raise Program_Error with "Right cursor is bad";
181 pragma Assert (Vet (Left.Container.Tree, Left.Node),
182 "bad Left cursor in ""<""");
184 pragma Assert (Vet (Right.Container.Tree, Right.Node),
185 "bad Right cursor in ""<""");
187 return Left.Node.Element.all < Right.Node.Element.all;
190 function "<" (Left : Cursor; Right : Element_Type) return Boolean is
192 if Left.Node = null then
193 raise Constraint_Error with "Left cursor equals No_Element";
196 if Left.Node.Element = null then
197 raise Program_Error with "Left cursor is bad";
200 pragma Assert (Vet (Left.Container.Tree, Left.Node),
201 "bad Left cursor in ""<""");
203 return Left.Node.Element.all < Right;
206 function "<" (Left : Element_Type; Right : Cursor) return Boolean is
208 if Right.Node = null then
209 raise Constraint_Error with "Right cursor equals No_Element";
212 if Right.Node.Element = null then
213 raise Program_Error with "Right cursor is bad";
216 pragma Assert (Vet (Right.Container.Tree, Right.Node),
217 "bad Right cursor in ""<""");
219 return Left < Right.Node.Element.all;
226 function "=" (Left, Right : Set) return Boolean is
228 return Is_Equal (Left.Tree, Right.Tree);
235 function ">" (Left, Right : Cursor) return Boolean is
237 if Left.Node = null then
238 raise Constraint_Error with "Left cursor equals No_Element";
241 if Right.Node = null then
242 raise Constraint_Error with "Right cursor equals No_Element";
245 if Left.Node.Element = null then
246 raise Program_Error with "Left cursor is bad";
249 if Right.Node.Element = null then
250 raise Program_Error with "Right cursor is bad";
253 pragma Assert (Vet (Left.Container.Tree, Left.Node),
254 "bad Left cursor in "">""");
256 pragma Assert (Vet (Right.Container.Tree, Right.Node),
257 "bad Right cursor in "">""");
259 -- L > R same as R < L
261 return Right.Node.Element.all < Left.Node.Element.all;
264 function ">" (Left : Cursor; Right : Element_Type) return Boolean is
266 if Left.Node = null then
267 raise Constraint_Error with "Left cursor equals No_Element";
270 if Left.Node.Element = null then
271 raise Program_Error with "Left cursor is bad";
274 pragma Assert (Vet (Left.Container.Tree, Left.Node),
275 "bad Left cursor in "">""");
277 return Right < Left.Node.Element.all;
280 function ">" (Left : Element_Type; Right : Cursor) return Boolean is
282 if Right.Node = null then
283 raise Constraint_Error with "Right cursor equals No_Element";
286 if Right.Node.Element = null then
287 raise Program_Error with "Right cursor is bad";
290 pragma Assert (Vet (Right.Container.Tree, Right.Node),
291 "bad Right cursor in "">""");
293 return Right.Node.Element.all < Left;
301 new Tree_Operations.Generic_Adjust (Copy_Tree);
303 procedure Adjust (Container : in out Set) is
305 Adjust (Container.Tree);
312 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
313 Node : constant Node_Access :=
314 Element_Keys.Ceiling (Container.Tree, Item);
321 return Cursor'(Container'Unrestricted_Access, Node);
329 new Tree_Operations.Generic_Clear (Delete_Tree);
331 procedure Clear (Container : in out Set) is
333 Clear (Container.Tree);
340 function Color (Node : Node_Access) return Color_Type is
349 function Contains (Container : Set; Item : Element_Type) return Boolean is
351 return Find (Container, Item) /= No_Element;
358 function Copy_Node (Source : Node_Access) return Node_Access is
359 X : Element_Access := new Element_Type'(Source.Element.all);
362 return new Node_Type'(Parent => null,
365 Color => Source.Color,
378 procedure Delete (Container : in out Set; Item : Element_Type) is
379 Tree : Tree_Type renames Container.Tree;
380 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
381 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
386 raise Constraint_Error with "attempt to delete element not in set";
391 Node := Tree_Operations.Next (Node);
392 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
395 exit when Node = Done;
399 procedure Delete (Container : in out Set; Position : in out Cursor) is
401 if Position.Node = null then
402 raise Constraint_Error with "Position cursor equals No_Element";
405 if Position.Node.Element = null then
406 raise Program_Error with "Position cursor is bad";
409 if Position.Container /= Container'Unrestricted_Access then
410 raise Program_Error with "Position cursor designates wrong set";
413 pragma Assert (Vet (Container.Tree, Position.Node),
414 "bad cursor in Delete");
416 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
417 Free (Position.Node);
419 Position.Container := null;
426 procedure Delete_First (Container : in out Set) is
427 Tree : Tree_Type renames Container.Tree;
428 X : Node_Access := Tree.First;
435 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
443 procedure Delete_Last (Container : in out Set) is
444 Tree : Tree_Type renames Container.Tree;
445 X : Node_Access := Tree.Last;
452 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
460 procedure Difference (Target : in out Set; Source : Set) is
462 Set_Ops.Difference (Target.Tree, Source.Tree);
465 function Difference (Left, Right : Set) return Set is
466 Tree : constant Tree_Type :=
467 Set_Ops.Difference (Left.Tree, Right.Tree);
469 return Set'(Controlled with Tree);
476 function Element (Position : Cursor) return Element_Type is
478 if Position.Node = null then
479 raise Constraint_Error with "Position cursor equals No_Element";
482 if Position.Node.Element = null then
483 raise Program_Error with "Position cursor is bad";
486 pragma Assert (Vet (Position.Container.Tree, Position.Node),
487 "bad cursor in Element");
489 return Position.Node.Element.all;
492 -------------------------
493 -- Equivalent_Elements --
494 -------------------------
496 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
505 end Equivalent_Elements;
507 ---------------------
508 -- Equivalent_Sets --
509 ---------------------
511 function Equivalent_Sets (Left, Right : Set) return Boolean is
513 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
514 pragma Inline (Is_Equivalent_Node_Node);
516 function Is_Equivalent is
517 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
519 -----------------------------
520 -- Is_Equivalent_Node_Node --
521 -----------------------------
523 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
525 if L.Element.all < R.Element.all then
527 elsif R.Element.all < L.Element.all then
532 end Is_Equivalent_Node_Node;
534 -- Start of processing for Equivalent_Sets
537 return Is_Equivalent (Left.Tree, Right.Tree);
544 procedure Exclude (Container : in out Set; Item : Element_Type) is
545 Tree : Tree_Type renames Container.Tree;
546 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
547 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
551 while Node /= Done loop
553 Node := Tree_Operations.Next (Node);
554 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
563 function Find (Container : Set; Item : Element_Type) return Cursor is
564 Node : constant Node_Access :=
565 Element_Keys.Find (Container.Tree, Item);
572 return Cursor'(Container'Unrestricted_Access, Node);
579 function First (Container : Set) return Cursor is
581 if Container.Tree.First = null then
585 return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
592 function First_Element (Container : Set) return Element_Type is
594 if Container.Tree.First = null then
595 raise Constraint_Error with "set is empty";
598 pragma Assert (Container.Tree.First.Element /= null);
599 return Container.Tree.First.Element.all;
606 function Floor (Container : Set; Item : Element_Type) return Cursor is
607 Node : constant Node_Access :=
608 Element_Keys.Floor (Container.Tree, Item);
615 return Cursor'(Container'Unrestricted_Access, Node);
622 procedure Free (X : in out Node_Access) is
623 procedure Deallocate is
624 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
636 Free_Element (X.Element);
651 package body Generic_Keys is
653 -----------------------
654 -- Local Subprograms --
655 -----------------------
657 function Is_Less_Key_Node
659 Right : Node_Access) return Boolean;
660 pragma Inline (Is_Less_Key_Node);
662 function Is_Greater_Key_Node
664 Right : Node_Access) return Boolean;
665 pragma Inline (Is_Greater_Key_Node);
667 --------------------------
668 -- Local Instantiations --
669 --------------------------
672 new Red_Black_Trees.Generic_Keys
673 (Tree_Operations => Tree_Operations,
674 Key_Type => Key_Type,
675 Is_Less_Key_Node => Is_Less_Key_Node,
676 Is_Greater_Key_Node => Is_Greater_Key_Node);
682 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
683 Node : constant Node_Access :=
684 Key_Keys.Ceiling (Container.Tree, Key);
691 return Cursor'(Container'Unrestricted_Access, Node);
698 function Contains (Container : Set; Key : Key_Type) return Boolean is
700 return Find (Container, Key) /= No_Element;
707 procedure Delete (Container : in out Set; Key : Key_Type) is
708 Tree : Tree_Type renames Container.Tree;
709 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
710 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
715 raise Constraint_Error with "attempt to delete key not in set";
720 Node := Tree_Operations.Next (Node);
721 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
724 exit when Node = Done;
732 function Element (Container : Set; Key : Key_Type) return Element_Type is
733 Node : constant Node_Access :=
734 Key_Keys.Find (Container.Tree, Key);
738 raise Constraint_Error with "key not in set";
741 return Node.Element.all;
744 ---------------------
745 -- Equivalent_Keys --
746 ---------------------
748 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
763 procedure Exclude (Container : in out Set; Key : Key_Type) is
764 Tree : Tree_Type renames Container.Tree;
765 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
766 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
770 while Node /= Done loop
772 Node := Tree_Operations.Next (Node);
773 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
782 function Find (Container : Set; Key : Key_Type) return Cursor is
783 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
790 return Cursor'(Container'Unrestricted_Access, Node);
797 function Floor (Container : Set; Key : Key_Type) return Cursor is
798 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
805 return Cursor'(Container'Unrestricted_Access, Node);
808 -------------------------
809 -- Is_Greater_Key_Node --
810 -------------------------
812 function Is_Greater_Key_Node
814 Right : Node_Access) return Boolean
817 return Key (Right.Element.all) < Left;
818 end Is_Greater_Key_Node;
820 ----------------------
821 -- Is_Less_Key_Node --
822 ----------------------
824 function Is_Less_Key_Node
826 Right : Node_Access) return Boolean
829 return Left < Key (Right.Element.all);
830 end Is_Less_Key_Node;
839 Process : not null access procedure (Position : Cursor))
841 procedure Process_Node (Node : Node_Access);
842 pragma Inline (Process_Node);
844 procedure Local_Iterate is
845 new Key_Keys.Generic_Iteration (Process_Node);
851 procedure Process_Node (Node : Node_Access) is
853 Process (Cursor'(Container'Unrestricted_Access, Node));
856 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
857 B : Natural renames T.Busy;
859 -- Start of processing for Iterate
865 Local_Iterate (T, Key);
879 function Key (Position : Cursor) return Key_Type is
881 if Position.Node = null then
882 raise Constraint_Error with
883 "Position cursor equals No_Element";
886 if Position.Node.Element = null then
887 raise Program_Error with
888 "Position cursor is bad";
891 pragma Assert (Vet (Position.Container.Tree, Position.Node),
892 "bad cursor in Key");
894 return Key (Position.Node.Element.all);
897 ---------------------
898 -- Reverse_Iterate --
899 ---------------------
901 procedure Reverse_Iterate
904 Process : not null access procedure (Position : Cursor))
906 procedure Process_Node (Node : Node_Access);
907 pragma Inline (Process_Node);
913 procedure Local_Reverse_Iterate is
914 new Key_Keys.Generic_Reverse_Iteration (Process_Node);
920 procedure Process_Node (Node : Node_Access) is
922 Process (Cursor'(Container'Unrestricted_Access, Node));
925 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
926 B : Natural renames T.Busy;
928 -- Start of processing for Reverse_Iterate
934 Local_Reverse_Iterate (T, Key);
948 procedure Update_Element
949 (Container : in out Set;
951 Process : not null access procedure (Element : in out Element_Type))
953 Tree : Tree_Type renames Container.Tree;
954 Node : constant Node_Access := Position.Node;
958 raise Constraint_Error with "Position cursor equals No_Element";
961 if Node.Element = null then
962 raise Program_Error with "Position cursor is bad";
965 if Position.Container /= Container'Unrestricted_Access then
966 raise Program_Error with "Position cursor designates wrong set";
969 pragma Assert (Vet (Tree, Node),
970 "bad cursor in Update_Element");
973 E : Element_Type renames Node.Element.all;
974 K : constant Key_Type := Key (E);
976 B : Natural renames Tree.Busy;
977 L : Natural renames Tree.Lock;
995 if Equivalent_Keys (Left => K, Right => Key (E)) then
1000 -- Delete_Node checks busy-bit
1002 Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
1004 Insert_New_Item : declare
1005 function New_Node return Node_Access;
1006 pragma Inline (New_Node);
1008 procedure Insert_Post is
1009 new Element_Keys.Generic_Insert_Post (New_Node);
1011 procedure Unconditional_Insert is
1012 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1018 function New_Node return Node_Access is
1020 Node.Color := Red_Black_Trees.Red;
1021 Node.Parent := null;
1028 Result : Node_Access;
1030 -- Start of processing for Insert_New_Item
1033 Unconditional_Insert
1035 Key => Node.Element.all,
1038 pragma Assert (Result = Node);
1039 end Insert_New_Item;
1048 function Has_Element (Position : Cursor) return Boolean is
1050 return Position /= No_Element;
1057 procedure Insert (Container : in out Set; New_Item : Element_Type) is
1060 Insert (Container, New_Item, Position);
1064 (Container : in out Set;
1065 New_Item : Element_Type;
1066 Position : out Cursor)
1069 Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
1070 Position.Container := Container'Unrestricted_Access;
1073 ----------------------
1074 -- Insert_Sans_Hint --
1075 ----------------------
1077 procedure Insert_Sans_Hint
1078 (Tree : in out Tree_Type;
1079 New_Item : Element_Type;
1080 Node : out Node_Access)
1082 function New_Node return Node_Access;
1083 pragma Inline (New_Node);
1085 procedure Insert_Post is
1086 new Element_Keys.Generic_Insert_Post (New_Node);
1088 procedure Unconditional_Insert is
1089 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1095 function New_Node return Node_Access is
1096 Element : Element_Access := new Element_Type'(New_Item);
1099 return new Node_Type'(Parent => null,
1102 Color => Red_Black_Trees.Red,
1103 Element => Element);
1106 Free_Element (Element);
1110 -- Start of processing for Insert_Sans_Hint
1113 Unconditional_Insert (Tree, New_Item, Node);
1114 end Insert_Sans_Hint;
1116 ----------------------
1117 -- Insert_With_Hint --
1118 ----------------------
1120 procedure Insert_With_Hint
1121 (Dst_Tree : in out Tree_Type;
1122 Dst_Hint : Node_Access;
1123 Src_Node : Node_Access;
1124 Dst_Node : out Node_Access)
1126 function New_Node return Node_Access;
1127 pragma Inline (New_Node);
1129 procedure Insert_Post is
1130 new Element_Keys.Generic_Insert_Post (New_Node);
1132 procedure Insert_Sans_Hint is
1133 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1135 procedure Local_Insert_With_Hint is
1136 new Element_Keys.Generic_Unconditional_Insert_With_Hint
1144 function New_Node return Node_Access is
1145 X : Element_Access := new Element_Type'(Src_Node.Element.all);
1148 return new Node_Type'(Parent => null,
1160 -- Start of processing for Insert_With_Hint
1163 Local_Insert_With_Hint
1166 Src_Node.Element.all,
1168 end Insert_With_Hint;
1174 procedure Intersection (Target : in out Set; Source : Set) is
1176 Set_Ops.Intersection (Target.Tree, Source.Tree);
1179 function Intersection (Left, Right : Set) return Set is
1180 Tree : constant Tree_Type :=
1181 Set_Ops.Intersection (Left.Tree, Right.Tree);
1183 return Set'(Controlled with Tree);
1190 function Is_Empty (Container : Set) return Boolean is
1192 return Container.Tree.Length = 0;
1195 ------------------------
1196 -- Is_Equal_Node_Node --
1197 ------------------------
1199 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1201 return L.Element.all = R.Element.all;
1202 end Is_Equal_Node_Node;
1204 -----------------------------
1205 -- Is_Greater_Element_Node --
1206 -----------------------------
1208 function Is_Greater_Element_Node
1209 (Left : Element_Type;
1210 Right : Node_Access) return Boolean
1213 -- e > node same as node < e
1215 return Right.Element.all < Left;
1216 end Is_Greater_Element_Node;
1218 --------------------------
1219 -- Is_Less_Element_Node --
1220 --------------------------
1222 function Is_Less_Element_Node
1223 (Left : Element_Type;
1224 Right : Node_Access) return Boolean
1227 return Left < Right.Element.all;
1228 end Is_Less_Element_Node;
1230 -----------------------
1231 -- Is_Less_Node_Node --
1232 -----------------------
1234 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1236 return L.Element.all < R.Element.all;
1237 end Is_Less_Node_Node;
1243 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1245 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1254 Item : Element_Type;
1255 Process : not null access procedure (Position : Cursor))
1257 procedure Process_Node (Node : Node_Access);
1258 pragma Inline (Process_Node);
1260 procedure Local_Iterate is
1261 new Element_Keys.Generic_Iteration (Process_Node);
1267 procedure Process_Node (Node : Node_Access) is
1269 Process (Cursor'(Container'Unrestricted_Access, Node));
1272 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1273 B : Natural renames T.Busy;
1275 -- Start of processing for Iterate
1281 Local_Iterate (T, Item);
1293 Process : not null access procedure (Position : Cursor))
1295 procedure Process_Node (Node : Node_Access);
1296 pragma Inline (Process_Node);
1298 procedure Local_Iterate is
1299 new Tree_Operations.Generic_Iteration (Process_Node);
1305 procedure Process_Node (Node : Node_Access) is
1307 Process (Cursor'(Container'Unrestricted_Access, Node));
1310 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1311 B : Natural renames T.Busy;
1313 -- Start of processing for Iterate
1333 function Last (Container : Set) return Cursor is
1335 if Container.Tree.Last = null then
1339 return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1346 function Last_Element (Container : Set) return Element_Type is
1348 if Container.Tree.Last = null then
1349 raise Constraint_Error with "set is empty";
1352 pragma Assert (Container.Tree.Last.Element /= null);
1353 return Container.Tree.Last.Element.all;
1360 function Left (Node : Node_Access) return Node_Access is
1369 function Length (Container : Set) return Count_Type is
1371 return Container.Tree.Length;
1379 new Tree_Operations.Generic_Move (Clear);
1381 procedure Move (Target : in out Set; Source : in out Set) is
1383 Move (Target => Target.Tree, Source => Source.Tree);
1390 function Next (Position : Cursor) return Cursor is
1392 if Position = No_Element then
1396 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1397 "bad cursor in Next");
1400 Node : constant Node_Access :=
1401 Tree_Operations.Next (Position.Node);
1408 return Cursor'(Position.Container, Node);
1412 procedure Next (Position : in out Cursor) is
1414 Position := Next (Position);
1421 function Overlap (Left, Right : Set) return Boolean is
1423 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1430 function Parent (Node : Node_Access) return Node_Access is
1439 function Previous (Position : Cursor) return Cursor is
1441 if Position = No_Element then
1445 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1446 "bad cursor in Previous");
1449 Node : constant Node_Access :=
1450 Tree_Operations.Previous (Position.Node);
1457 return Cursor'(Position.Container, Node);
1461 procedure Previous (Position : in out Cursor) is
1463 Position := Previous (Position);
1470 procedure Query_Element
1472 Process : not null access procedure (Element : Element_Type))
1475 if Position.Node = null then
1476 raise Constraint_Error with "Position cursor equals No_Element";
1479 if Position.Node.Element = null then
1480 raise Program_Error with "Position cursor is bad";
1483 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1484 "bad cursor in Query_Element");
1487 T : Tree_Type renames Position.Container.Tree;
1489 B : Natural renames T.Busy;
1490 L : Natural renames T.Lock;
1497 Process (Position.Node.Element.all);
1515 (Stream : access Root_Stream_Type'Class;
1516 Container : out Set)
1519 (Stream : access Root_Stream_Type'Class) return Node_Access;
1520 pragma Inline (Read_Node);
1523 new Tree_Operations.Generic_Read (Clear, Read_Node);
1530 (Stream : access Root_Stream_Type'Class) return Node_Access
1532 Node : Node_Access := new Node_Type;
1534 Node.Element := new Element_Type'(Element_Type'Input (Stream));
1538 Free (Node); -- Note that Free deallocates elem too
1542 -- Start of processing for Read
1545 Read (Stream, Container.Tree);
1549 (Stream : access Root_Stream_Type'Class;
1553 raise Program_Error with "attempt to stream set cursor";
1556 ---------------------
1557 -- Replace_Element --
1558 ---------------------
1560 procedure Replace_Element
1561 (Tree : in out Tree_Type;
1563 Item : Element_Type)
1566 if Item < Node.Element.all
1567 or else Node.Element.all < Item
1571 if Tree.Lock > 0 then
1572 raise Program_Error with
1573 "attempt to tamper with cursors (set is locked)";
1577 X : Element_Access := Node.Element;
1579 Node.Element := new Element_Type'(Item);
1586 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
1588 Insert_New_Item : declare
1589 function New_Node return Node_Access;
1590 pragma Inline (New_Node);
1592 procedure Insert_Post is
1593 new Element_Keys.Generic_Insert_Post (New_Node);
1595 procedure Unconditional_Insert is
1596 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1602 function New_Node return Node_Access is
1604 Node.Element := new Element_Type'(Item); -- OK if fails
1605 Node.Color := Red_Black_Trees.Red;
1606 Node.Parent := null;
1613 Result : Node_Access;
1615 X : Element_Access := Node.Element;
1617 -- Start of processing for Insert_New_Item
1620 Unconditional_Insert
1624 pragma Assert (Result = Node);
1626 Free_Element (X); -- OK if fails
1627 end Insert_New_Item;
1628 end Replace_Element;
1630 procedure Replace_Element
1631 (Container : in out Set;
1633 New_Item : Element_Type)
1636 if Position.Node = null then
1637 raise Constraint_Error with "Position cursor equals No_Element";
1640 if Position.Node.Element = null then
1641 raise Program_Error with "Position cursor is bad";
1644 if Position.Container /= Container'Unrestricted_Access then
1645 raise Program_Error with "Position cursor designates wrong set";
1648 pragma Assert (Vet (Container.Tree, Position.Node),
1649 "bad cursor in Replace_Element");
1651 Replace_Element (Container.Tree, Position.Node, New_Item);
1652 end Replace_Element;
1654 ---------------------
1655 -- Reverse_Iterate --
1656 ---------------------
1658 procedure Reverse_Iterate
1660 Item : Element_Type;
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 Element_Keys.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, Item);
1695 end Reverse_Iterate;
1697 procedure Reverse_Iterate
1699 Process : not null access procedure (Position : Cursor))
1701 procedure Process_Node (Node : Node_Access);
1702 pragma Inline (Process_Node);
1704 procedure Local_Reverse_Iterate is
1705 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1711 procedure Process_Node (Node : Node_Access) is
1713 Process (Cursor'(Container'Unrestricted_Access, Node));
1716 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1717 B : Natural renames T.Busy;
1719 -- Start of processing for Reverse_Iterate
1725 Local_Reverse_Iterate (T);
1733 end Reverse_Iterate;
1739 function Right (Node : Node_Access) return Node_Access is
1748 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1750 Node.Color := Color;
1757 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1766 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1768 Node.Parent := Parent;
1775 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1777 Node.Right := Right;
1780 --------------------------
1781 -- Symmetric_Difference --
1782 --------------------------
1784 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1786 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1787 end Symmetric_Difference;
1789 function Symmetric_Difference (Left, Right : Set) return Set is
1790 Tree : constant Tree_Type :=
1791 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1793 return Set'(Controlled with Tree);
1794 end Symmetric_Difference;
1800 function To_Set (New_Item : Element_Type) return Set is
1805 Insert_Sans_Hint (Tree, New_Item, Node);
1806 return Set'(Controlled with Tree);
1813 procedure Union (Target : in out Set; Source : Set) is
1815 Set_Ops.Union (Target.Tree, Source.Tree);
1818 function Union (Left, Right : Set) return Set is
1819 Tree : constant Tree_Type :=
1820 Set_Ops.Union (Left.Tree, Right.Tree);
1822 return Set'(Controlled with Tree);
1830 (Stream : access Root_Stream_Type'Class;
1833 procedure Write_Node
1834 (Stream : access Root_Stream_Type'Class;
1835 Node : Node_Access);
1836 pragma Inline (Write_Node);
1839 new Tree_Operations.Generic_Write (Write_Node);
1845 procedure Write_Node
1846 (Stream : access Root_Stream_Type'Class;
1850 Element_Type'Output (Stream, Node.Element.all);
1853 -- Start of processing for Write
1856 Write (Stream, Container.Tree);
1860 (Stream : access Root_Stream_Type'Class;
1864 raise Program_Error with "attempt to stream set cursor";
1867 end Ada.Containers.Indefinite_Ordered_Multisets;