1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS --
9 -- Copyright (C) 2004-2009, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada.Unchecked_Deallocation;
32 with Ada.Containers.Red_Black_Trees.Generic_Operations;
33 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
35 with Ada.Containers.Red_Black_Trees.Generic_Keys;
36 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
38 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
39 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
41 package body Ada.Containers.Indefinite_Ordered_Multisets is
43 -----------------------------
44 -- Node Access Subprograms --
45 -----------------------------
47 -- These subprograms provide a functional interface to access fields
48 -- of a node, and a procedural interface for modifying these values.
50 function Color (Node : Node_Access) return Color_Type;
51 pragma Inline (Color);
53 function Left (Node : Node_Access) return Node_Access;
56 function Parent (Node : Node_Access) return Node_Access;
57 pragma Inline (Parent);
59 function Right (Node : Node_Access) return Node_Access;
60 pragma Inline (Right);
62 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
63 pragma Inline (Set_Parent);
65 procedure Set_Left (Node : Node_Access; Left : Node_Access);
66 pragma Inline (Set_Left);
68 procedure Set_Right (Node : Node_Access; Right : Node_Access);
69 pragma Inline (Set_Right);
71 procedure Set_Color (Node : Node_Access; Color : Color_Type);
72 pragma Inline (Set_Color);
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 function Copy_Node (Source : Node_Access) return Node_Access;
79 pragma Inline (Copy_Node);
81 procedure Free (X : in out Node_Access);
83 procedure Insert_Sans_Hint
84 (Tree : in out Tree_Type;
85 New_Item : Element_Type;
86 Node : out Node_Access);
88 procedure Insert_With_Hint
89 (Dst_Tree : in out Tree_Type;
90 Dst_Hint : Node_Access;
91 Src_Node : Node_Access;
92 Dst_Node : out Node_Access);
94 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
95 pragma Inline (Is_Equal_Node_Node);
97 function Is_Greater_Element_Node
99 Right : Node_Access) return Boolean;
100 pragma Inline (Is_Greater_Element_Node);
102 function Is_Less_Element_Node
103 (Left : Element_Type;
104 Right : Node_Access) return Boolean;
105 pragma Inline (Is_Less_Element_Node);
107 function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
108 pragma Inline (Is_Less_Node_Node);
110 procedure Replace_Element
111 (Tree : in out Tree_Type;
113 Item : Element_Type);
115 --------------------------
116 -- Local Instantiations --
117 --------------------------
119 package Tree_Operations is
120 new Red_Black_Trees.Generic_Operations (Tree_Types);
122 procedure Delete_Tree is
123 new Tree_Operations.Generic_Delete_Tree (Free);
125 function Copy_Tree is
126 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
130 procedure Free_Element is
131 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
134 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
137 new Generic_Set_Operations
138 (Tree_Operations => Tree_Operations,
139 Insert_With_Hint => Insert_With_Hint,
140 Copy_Tree => Copy_Tree,
141 Delete_Tree => Delete_Tree,
142 Is_Less => Is_Less_Node_Node,
145 package Element_Keys is
146 new Red_Black_Trees.Generic_Keys
147 (Tree_Operations => Tree_Operations,
148 Key_Type => Element_Type,
149 Is_Less_Key_Node => Is_Less_Element_Node,
150 Is_Greater_Key_Node => Is_Greater_Element_Node);
156 function "<" (Left, Right : Cursor) return Boolean is
158 if Left.Node = null then
159 raise Constraint_Error with "Left cursor equals No_Element";
162 if Right.Node = null then
163 raise Constraint_Error with "Right cursor equals No_Element";
166 if Left.Node.Element = null then
167 raise Program_Error with "Left cursor is bad";
170 if Right.Node.Element = null then
171 raise Program_Error with "Right cursor is bad";
174 pragma Assert (Vet (Left.Container.Tree, Left.Node),
175 "bad Left cursor in ""<""");
177 pragma Assert (Vet (Right.Container.Tree, Right.Node),
178 "bad Right cursor in ""<""");
180 return Left.Node.Element.all < Right.Node.Element.all;
183 function "<" (Left : Cursor; Right : Element_Type) return Boolean is
185 if Left.Node = null then
186 raise Constraint_Error with "Left cursor equals No_Element";
189 if Left.Node.Element = null then
190 raise Program_Error with "Left cursor is bad";
193 pragma Assert (Vet (Left.Container.Tree, Left.Node),
194 "bad Left cursor in ""<""");
196 return Left.Node.Element.all < Right;
199 function "<" (Left : Element_Type; Right : Cursor) return Boolean is
201 if Right.Node = null then
202 raise Constraint_Error with "Right cursor equals No_Element";
205 if Right.Node.Element = null then
206 raise Program_Error with "Right cursor is bad";
209 pragma Assert (Vet (Right.Container.Tree, Right.Node),
210 "bad Right cursor in ""<""");
212 return Left < Right.Node.Element.all;
219 function "=" (Left, Right : Set) return Boolean is
221 return Is_Equal (Left.Tree, Right.Tree);
228 function ">" (Left, Right : Cursor) return Boolean is
230 if Left.Node = null then
231 raise Constraint_Error with "Left cursor equals No_Element";
234 if Right.Node = null then
235 raise Constraint_Error with "Right cursor equals No_Element";
238 if Left.Node.Element = null then
239 raise Program_Error with "Left cursor is bad";
242 if Right.Node.Element = null then
243 raise Program_Error with "Right cursor is bad";
246 pragma Assert (Vet (Left.Container.Tree, Left.Node),
247 "bad Left cursor in "">""");
249 pragma Assert (Vet (Right.Container.Tree, Right.Node),
250 "bad Right cursor in "">""");
252 -- L > R same as R < L
254 return Right.Node.Element.all < Left.Node.Element.all;
257 function ">" (Left : Cursor; Right : Element_Type) return Boolean is
259 if Left.Node = null then
260 raise Constraint_Error with "Left cursor equals No_Element";
263 if Left.Node.Element = null then
264 raise Program_Error with "Left cursor is bad";
267 pragma Assert (Vet (Left.Container.Tree, Left.Node),
268 "bad Left cursor in "">""");
270 return Right < Left.Node.Element.all;
273 function ">" (Left : Element_Type; Right : Cursor) return Boolean is
275 if Right.Node = null then
276 raise Constraint_Error with "Right cursor equals No_Element";
279 if Right.Node.Element = null then
280 raise Program_Error with "Right cursor is bad";
283 pragma Assert (Vet (Right.Container.Tree, Right.Node),
284 "bad Right cursor in "">""");
286 return Right.Node.Element.all < Left;
294 new Tree_Operations.Generic_Adjust (Copy_Tree);
296 procedure Adjust (Container : in out Set) is
298 Adjust (Container.Tree);
305 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
306 Node : constant Node_Access :=
307 Element_Keys.Ceiling (Container.Tree, Item);
314 return Cursor'(Container'Unrestricted_Access, Node);
322 new Tree_Operations.Generic_Clear (Delete_Tree);
324 procedure Clear (Container : in out Set) is
326 Clear (Container.Tree);
333 function Color (Node : Node_Access) return Color_Type is
342 function Contains (Container : Set; Item : Element_Type) return Boolean is
344 return Find (Container, Item) /= No_Element;
351 function Copy_Node (Source : Node_Access) return Node_Access is
352 X : Element_Access := new Element_Type'(Source.Element.all);
355 return new Node_Type'(Parent => null,
358 Color => Source.Color,
371 procedure Delete (Container : in out Set; Item : Element_Type) is
372 Tree : Tree_Type renames Container.Tree;
373 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
374 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
379 raise Constraint_Error with "attempt to delete element not in set";
384 Node := Tree_Operations.Next (Node);
385 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
388 exit when Node = Done;
392 procedure Delete (Container : in out Set; Position : in out Cursor) is
394 if Position.Node = null then
395 raise Constraint_Error with "Position cursor equals No_Element";
398 if Position.Node.Element = null then
399 raise Program_Error with "Position cursor is bad";
402 if Position.Container /= Container'Unrestricted_Access then
403 raise Program_Error with "Position cursor designates wrong set";
406 pragma Assert (Vet (Container.Tree, Position.Node),
407 "bad cursor in Delete");
409 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
410 Free (Position.Node);
412 Position.Container := null;
419 procedure Delete_First (Container : in out Set) is
420 Tree : Tree_Type renames Container.Tree;
421 X : Node_Access := Tree.First;
428 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
436 procedure Delete_Last (Container : in out Set) is
437 Tree : Tree_Type renames Container.Tree;
438 X : Node_Access := Tree.Last;
445 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
453 procedure Difference (Target : in out Set; Source : Set) is
455 Set_Ops.Difference (Target.Tree, Source.Tree);
458 function Difference (Left, Right : Set) return Set is
459 Tree : constant Tree_Type :=
460 Set_Ops.Difference (Left.Tree, Right.Tree);
462 return Set'(Controlled with Tree);
469 function Element (Position : Cursor) return Element_Type is
471 if Position.Node = null then
472 raise Constraint_Error with "Position cursor equals No_Element";
475 if Position.Node.Element = null then
476 raise Program_Error with "Position cursor is bad";
479 pragma Assert (Vet (Position.Container.Tree, Position.Node),
480 "bad cursor in Element");
482 return Position.Node.Element.all;
485 -------------------------
486 -- Equivalent_Elements --
487 -------------------------
489 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
498 end Equivalent_Elements;
500 ---------------------
501 -- Equivalent_Sets --
502 ---------------------
504 function Equivalent_Sets (Left, Right : Set) return Boolean is
506 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
507 pragma Inline (Is_Equivalent_Node_Node);
509 function Is_Equivalent is
510 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
512 -----------------------------
513 -- Is_Equivalent_Node_Node --
514 -----------------------------
516 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
518 if L.Element.all < R.Element.all then
520 elsif R.Element.all < L.Element.all then
525 end Is_Equivalent_Node_Node;
527 -- Start of processing for Equivalent_Sets
530 return Is_Equivalent (Left.Tree, Right.Tree);
537 procedure Exclude (Container : in out Set; Item : Element_Type) is
538 Tree : Tree_Type renames Container.Tree;
539 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
540 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
544 while Node /= Done loop
546 Node := Tree_Operations.Next (Node);
547 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
556 function Find (Container : Set; Item : Element_Type) return Cursor is
557 Node : constant Node_Access :=
558 Element_Keys.Find (Container.Tree, Item);
565 return Cursor'(Container'Unrestricted_Access, Node);
572 function First (Container : Set) return Cursor is
574 if Container.Tree.First = null then
578 return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
585 function First_Element (Container : Set) return Element_Type is
587 if Container.Tree.First = null then
588 raise Constraint_Error with "set is empty";
591 pragma Assert (Container.Tree.First.Element /= null);
592 return Container.Tree.First.Element.all;
599 function Floor (Container : Set; Item : Element_Type) return Cursor is
600 Node : constant Node_Access :=
601 Element_Keys.Floor (Container.Tree, Item);
608 return Cursor'(Container'Unrestricted_Access, Node);
615 procedure Free (X : in out Node_Access) is
616 procedure Deallocate is
617 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
629 Free_Element (X.Element);
644 package body Generic_Keys is
646 -----------------------
647 -- Local Subprograms --
648 -----------------------
650 function Is_Less_Key_Node
652 Right : Node_Access) return Boolean;
653 pragma Inline (Is_Less_Key_Node);
655 function Is_Greater_Key_Node
657 Right : Node_Access) return Boolean;
658 pragma Inline (Is_Greater_Key_Node);
660 --------------------------
661 -- Local Instantiations --
662 --------------------------
665 new Red_Black_Trees.Generic_Keys
666 (Tree_Operations => Tree_Operations,
667 Key_Type => Key_Type,
668 Is_Less_Key_Node => Is_Less_Key_Node,
669 Is_Greater_Key_Node => Is_Greater_Key_Node);
675 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
676 Node : constant Node_Access :=
677 Key_Keys.Ceiling (Container.Tree, Key);
684 return Cursor'(Container'Unrestricted_Access, Node);
691 function Contains (Container : Set; Key : Key_Type) return Boolean is
693 return Find (Container, Key) /= No_Element;
700 procedure Delete (Container : in out Set; Key : Key_Type) is
701 Tree : Tree_Type renames Container.Tree;
702 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
703 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
708 raise Constraint_Error with "attempt to delete key not in set";
713 Node := Tree_Operations.Next (Node);
714 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
717 exit when Node = Done;
725 function Element (Container : Set; Key : Key_Type) return Element_Type is
726 Node : constant Node_Access :=
727 Key_Keys.Find (Container.Tree, Key);
731 raise Constraint_Error with "key not in set";
734 return Node.Element.all;
737 ---------------------
738 -- Equivalent_Keys --
739 ---------------------
741 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
756 procedure Exclude (Container : in out Set; Key : Key_Type) is
757 Tree : Tree_Type renames Container.Tree;
758 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
759 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
763 while Node /= Done loop
765 Node := Tree_Operations.Next (Node);
766 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
775 function Find (Container : Set; Key : Key_Type) return Cursor is
776 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
783 return Cursor'(Container'Unrestricted_Access, Node);
790 function Floor (Container : Set; Key : Key_Type) return Cursor is
791 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
798 return Cursor'(Container'Unrestricted_Access, Node);
801 -------------------------
802 -- Is_Greater_Key_Node --
803 -------------------------
805 function Is_Greater_Key_Node
807 Right : Node_Access) return Boolean
810 return Key (Right.Element.all) < Left;
811 end Is_Greater_Key_Node;
813 ----------------------
814 -- Is_Less_Key_Node --
815 ----------------------
817 function Is_Less_Key_Node
819 Right : Node_Access) return Boolean
822 return Left < Key (Right.Element.all);
823 end Is_Less_Key_Node;
832 Process : not null access procedure (Position : Cursor))
834 procedure Process_Node (Node : Node_Access);
835 pragma Inline (Process_Node);
837 procedure Local_Iterate is
838 new Key_Keys.Generic_Iteration (Process_Node);
844 procedure Process_Node (Node : Node_Access) is
846 Process (Cursor'(Container'Unrestricted_Access, Node));
849 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
850 B : Natural renames T.Busy;
852 -- Start of processing for Iterate
858 Local_Iterate (T, Key);
872 function Key (Position : Cursor) return Key_Type is
874 if Position.Node = null then
875 raise Constraint_Error with
876 "Position cursor equals No_Element";
879 if Position.Node.Element = null then
880 raise Program_Error with
881 "Position cursor is bad";
884 pragma Assert (Vet (Position.Container.Tree, Position.Node),
885 "bad cursor in Key");
887 return Key (Position.Node.Element.all);
890 ---------------------
891 -- Reverse_Iterate --
892 ---------------------
894 procedure Reverse_Iterate
897 Process : not null access procedure (Position : Cursor))
899 procedure Process_Node (Node : Node_Access);
900 pragma Inline (Process_Node);
906 procedure Local_Reverse_Iterate is
907 new Key_Keys.Generic_Reverse_Iteration (Process_Node);
913 procedure Process_Node (Node : Node_Access) is
915 Process (Cursor'(Container'Unrestricted_Access, Node));
918 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
919 B : Natural renames T.Busy;
921 -- Start of processing for Reverse_Iterate
927 Local_Reverse_Iterate (T, Key);
941 procedure Update_Element
942 (Container : in out Set;
944 Process : not null access procedure (Element : in out Element_Type))
946 Tree : Tree_Type renames Container.Tree;
947 Node : constant Node_Access := Position.Node;
951 raise Constraint_Error with "Position cursor equals No_Element";
954 if Node.Element = null then
955 raise Program_Error with "Position cursor is bad";
958 if Position.Container /= Container'Unrestricted_Access then
959 raise Program_Error with "Position cursor designates wrong set";
962 pragma Assert (Vet (Tree, Node),
963 "bad cursor in Update_Element");
966 E : Element_Type renames Node.Element.all;
967 K : constant Key_Type := Key (E);
969 B : Natural renames Tree.Busy;
970 L : Natural renames Tree.Lock;
988 if Equivalent_Keys (Left => K, Right => Key (E)) then
993 -- Delete_Node checks busy-bit
995 Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
997 Insert_New_Item : declare
998 function New_Node return Node_Access;
999 pragma Inline (New_Node);
1001 procedure Insert_Post is
1002 new Element_Keys.Generic_Insert_Post (New_Node);
1004 procedure Unconditional_Insert is
1005 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1011 function New_Node return Node_Access is
1013 Node.Color := Red_Black_Trees.Red;
1014 Node.Parent := null;
1021 Result : Node_Access;
1023 -- Start of processing for Insert_New_Item
1026 Unconditional_Insert
1028 Key => Node.Element.all,
1031 pragma Assert (Result = Node);
1032 end Insert_New_Item;
1041 function Has_Element (Position : Cursor) return Boolean is
1043 return Position /= No_Element;
1050 procedure Insert (Container : in out Set; New_Item : Element_Type) is
1052 pragma Unreferenced (Position);
1054 Insert (Container, New_Item, Position);
1058 (Container : in out Set;
1059 New_Item : Element_Type;
1060 Position : out Cursor)
1063 Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
1064 Position.Container := Container'Unrestricted_Access;
1067 ----------------------
1068 -- Insert_Sans_Hint --
1069 ----------------------
1071 procedure Insert_Sans_Hint
1072 (Tree : in out Tree_Type;
1073 New_Item : Element_Type;
1074 Node : out Node_Access)
1076 function New_Node return Node_Access;
1077 pragma Inline (New_Node);
1079 procedure Insert_Post is
1080 new Element_Keys.Generic_Insert_Post (New_Node);
1082 procedure Unconditional_Insert is
1083 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1089 function New_Node return Node_Access is
1090 Element : Element_Access := new Element_Type'(New_Item);
1093 return new Node_Type'(Parent => null,
1096 Color => Red_Black_Trees.Red,
1097 Element => Element);
1100 Free_Element (Element);
1104 -- Start of processing for Insert_Sans_Hint
1107 Unconditional_Insert (Tree, New_Item, Node);
1108 end Insert_Sans_Hint;
1110 ----------------------
1111 -- Insert_With_Hint --
1112 ----------------------
1114 procedure Insert_With_Hint
1115 (Dst_Tree : in out Tree_Type;
1116 Dst_Hint : Node_Access;
1117 Src_Node : Node_Access;
1118 Dst_Node : out Node_Access)
1120 function New_Node return Node_Access;
1121 pragma Inline (New_Node);
1123 procedure Insert_Post is
1124 new Element_Keys.Generic_Insert_Post (New_Node);
1126 procedure Insert_Sans_Hint is
1127 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1129 procedure Local_Insert_With_Hint is
1130 new Element_Keys.Generic_Unconditional_Insert_With_Hint
1138 function New_Node return Node_Access is
1139 X : Element_Access := new Element_Type'(Src_Node.Element.all);
1142 return new Node_Type'(Parent => null,
1154 -- Start of processing for Insert_With_Hint
1157 Local_Insert_With_Hint
1160 Src_Node.Element.all,
1162 end Insert_With_Hint;
1168 procedure Intersection (Target : in out Set; Source : Set) is
1170 Set_Ops.Intersection (Target.Tree, Source.Tree);
1173 function Intersection (Left, Right : Set) return Set is
1174 Tree : constant Tree_Type :=
1175 Set_Ops.Intersection (Left.Tree, Right.Tree);
1177 return Set'(Controlled with Tree);
1184 function Is_Empty (Container : Set) return Boolean is
1186 return Container.Tree.Length = 0;
1189 ------------------------
1190 -- Is_Equal_Node_Node --
1191 ------------------------
1193 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1195 return L.Element.all = R.Element.all;
1196 end Is_Equal_Node_Node;
1198 -----------------------------
1199 -- Is_Greater_Element_Node --
1200 -----------------------------
1202 function Is_Greater_Element_Node
1203 (Left : Element_Type;
1204 Right : Node_Access) return Boolean
1207 -- e > node same as node < e
1209 return Right.Element.all < Left;
1210 end Is_Greater_Element_Node;
1212 --------------------------
1213 -- Is_Less_Element_Node --
1214 --------------------------
1216 function Is_Less_Element_Node
1217 (Left : Element_Type;
1218 Right : Node_Access) return Boolean
1221 return Left < Right.Element.all;
1222 end Is_Less_Element_Node;
1224 -----------------------
1225 -- Is_Less_Node_Node --
1226 -----------------------
1228 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1230 return L.Element.all < R.Element.all;
1231 end Is_Less_Node_Node;
1237 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1239 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1248 Item : Element_Type;
1249 Process : not null access procedure (Position : Cursor))
1251 procedure Process_Node (Node : Node_Access);
1252 pragma Inline (Process_Node);
1254 procedure Local_Iterate is
1255 new Element_Keys.Generic_Iteration (Process_Node);
1261 procedure Process_Node (Node : Node_Access) is
1263 Process (Cursor'(Container'Unrestricted_Access, Node));
1266 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1267 B : Natural renames T.Busy;
1269 -- Start of processing for Iterate
1275 Local_Iterate (T, Item);
1287 Process : not null access procedure (Position : Cursor))
1289 procedure Process_Node (Node : Node_Access);
1290 pragma Inline (Process_Node);
1292 procedure Local_Iterate is
1293 new Tree_Operations.Generic_Iteration (Process_Node);
1299 procedure Process_Node (Node : Node_Access) is
1301 Process (Cursor'(Container'Unrestricted_Access, Node));
1304 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1305 B : Natural renames T.Busy;
1307 -- Start of processing for Iterate
1327 function Last (Container : Set) return Cursor is
1329 if Container.Tree.Last = null then
1333 return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1340 function Last_Element (Container : Set) return Element_Type is
1342 if Container.Tree.Last = null then
1343 raise Constraint_Error with "set is empty";
1346 pragma Assert (Container.Tree.Last.Element /= null);
1347 return Container.Tree.Last.Element.all;
1354 function Left (Node : Node_Access) return Node_Access is
1363 function Length (Container : Set) return Count_Type is
1365 return Container.Tree.Length;
1373 new Tree_Operations.Generic_Move (Clear);
1375 procedure Move (Target : in out Set; Source : in out Set) is
1377 Move (Target => Target.Tree, Source => Source.Tree);
1384 function Next (Position : Cursor) return Cursor is
1386 if Position = No_Element then
1390 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1391 "bad cursor in Next");
1394 Node : constant Node_Access :=
1395 Tree_Operations.Next (Position.Node);
1402 return Cursor'(Position.Container, Node);
1406 procedure Next (Position : in out Cursor) is
1408 Position := Next (Position);
1415 function Overlap (Left, Right : Set) return Boolean is
1417 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1424 function Parent (Node : Node_Access) return Node_Access is
1433 function Previous (Position : Cursor) return Cursor is
1435 if Position = No_Element then
1439 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1440 "bad cursor in Previous");
1443 Node : constant Node_Access :=
1444 Tree_Operations.Previous (Position.Node);
1451 return Cursor'(Position.Container, Node);
1455 procedure Previous (Position : in out Cursor) is
1457 Position := Previous (Position);
1464 procedure Query_Element
1466 Process : not null access procedure (Element : Element_Type))
1469 if Position.Node = null then
1470 raise Constraint_Error with "Position cursor equals No_Element";
1473 if Position.Node.Element = null then
1474 raise Program_Error with "Position cursor is bad";
1477 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1478 "bad cursor in Query_Element");
1481 T : Tree_Type renames Position.Container.Tree;
1483 B : Natural renames T.Busy;
1484 L : Natural renames T.Lock;
1491 Process (Position.Node.Element.all);
1509 (Stream : not null access Root_Stream_Type'Class;
1510 Container : out Set)
1513 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1514 pragma Inline (Read_Node);
1517 new Tree_Operations.Generic_Read (Clear, Read_Node);
1524 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1526 Node : Node_Access := new Node_Type;
1528 Node.Element := new Element_Type'(Element_Type'Input (Stream));
1532 Free (Node); -- Note that Free deallocates elem too
1536 -- Start of processing for Read
1539 Read (Stream, Container.Tree);
1543 (Stream : not null access Root_Stream_Type'Class;
1547 raise Program_Error with "attempt to stream set cursor";
1550 ---------------------
1551 -- Replace_Element --
1552 ---------------------
1554 procedure Replace_Element
1555 (Tree : in out Tree_Type;
1557 Item : Element_Type)
1560 if Item < Node.Element.all
1561 or else Node.Element.all < Item
1565 if Tree.Lock > 0 then
1566 raise Program_Error with
1567 "attempt to tamper with cursors (set is locked)";
1571 X : Element_Access := Node.Element;
1573 Node.Element := new Element_Type'(Item);
1580 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
1582 Insert_New_Item : declare
1583 function New_Node return Node_Access;
1584 pragma Inline (New_Node);
1586 procedure Insert_Post is
1587 new Element_Keys.Generic_Insert_Post (New_Node);
1589 procedure Unconditional_Insert is
1590 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1596 function New_Node return Node_Access is
1598 Node.Element := new Element_Type'(Item); -- OK if fails
1599 Node.Color := Red_Black_Trees.Red;
1600 Node.Parent := null;
1607 Result : Node_Access;
1609 X : Element_Access := Node.Element;
1611 -- Start of processing for Insert_New_Item
1614 Unconditional_Insert
1618 pragma Assert (Result = Node);
1620 Free_Element (X); -- OK if fails
1621 end Insert_New_Item;
1622 end Replace_Element;
1624 procedure Replace_Element
1625 (Container : in out Set;
1627 New_Item : Element_Type)
1630 if Position.Node = null then
1631 raise Constraint_Error with "Position cursor equals No_Element";
1634 if Position.Node.Element = null then
1635 raise Program_Error with "Position cursor is bad";
1638 if Position.Container /= Container'Unrestricted_Access then
1639 raise Program_Error with "Position cursor designates wrong set";
1642 pragma Assert (Vet (Container.Tree, Position.Node),
1643 "bad cursor in Replace_Element");
1645 Replace_Element (Container.Tree, Position.Node, New_Item);
1646 end Replace_Element;
1648 ---------------------
1649 -- Reverse_Iterate --
1650 ---------------------
1652 procedure Reverse_Iterate
1654 Item : Element_Type;
1655 Process : not null access procedure (Position : Cursor))
1657 procedure Process_Node (Node : Node_Access);
1658 pragma Inline (Process_Node);
1660 procedure Local_Reverse_Iterate is
1661 new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1667 procedure Process_Node (Node : Node_Access) is
1669 Process (Cursor'(Container'Unrestricted_Access, Node));
1672 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1673 B : Natural renames T.Busy;
1675 -- Start of processing for Reverse_Iterate
1681 Local_Reverse_Iterate (T, Item);
1689 end Reverse_Iterate;
1691 procedure Reverse_Iterate
1693 Process : not null access procedure (Position : Cursor))
1695 procedure Process_Node (Node : Node_Access);
1696 pragma Inline (Process_Node);
1698 procedure Local_Reverse_Iterate is
1699 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1705 procedure Process_Node (Node : Node_Access) is
1707 Process (Cursor'(Container'Unrestricted_Access, Node));
1710 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1711 B : Natural renames T.Busy;
1713 -- Start of processing for Reverse_Iterate
1719 Local_Reverse_Iterate (T);
1727 end Reverse_Iterate;
1733 function Right (Node : Node_Access) return Node_Access is
1742 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1744 Node.Color := Color;
1751 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1760 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1762 Node.Parent := Parent;
1769 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1771 Node.Right := Right;
1774 --------------------------
1775 -- Symmetric_Difference --
1776 --------------------------
1778 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1780 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1781 end Symmetric_Difference;
1783 function Symmetric_Difference (Left, Right : Set) return Set is
1784 Tree : constant Tree_Type :=
1785 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1787 return Set'(Controlled with Tree);
1788 end Symmetric_Difference;
1794 function To_Set (New_Item : Element_Type) return Set is
1797 pragma Unreferenced (Node);
1799 Insert_Sans_Hint (Tree, New_Item, Node);
1800 return Set'(Controlled with Tree);
1807 procedure Union (Target : in out Set; Source : Set) is
1809 Set_Ops.Union (Target.Tree, Source.Tree);
1812 function Union (Left, Right : Set) return Set is
1813 Tree : constant Tree_Type :=
1814 Set_Ops.Union (Left.Tree, Right.Tree);
1816 return Set'(Controlled with Tree);
1824 (Stream : not null access Root_Stream_Type'Class;
1827 procedure Write_Node
1828 (Stream : not null access Root_Stream_Type'Class;
1829 Node : Node_Access);
1830 pragma Inline (Write_Node);
1833 new Tree_Operations.Generic_Write (Write_Node);
1839 procedure Write_Node
1840 (Stream : not null access Root_Stream_Type'Class;
1844 Element_Type'Output (Stream, Node.Element.all);
1847 -- Start of processing for Write
1850 Write (Stream, Container.Tree);
1854 (Stream : not null access Root_Stream_Type'Class;
1858 raise Program_Error with "attempt to stream set cursor";
1861 end Ada.Containers.Indefinite_Ordered_Multisets;