1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S --
9 -- Copyright (C) 2004-2013, 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 with System; use type System.Address;
43 package body Ada.Containers.Ordered_Multisets is
45 -----------------------------
46 -- Node Access Subprograms --
47 -----------------------------
49 -- These subprograms provide a functional interface to access fields
50 -- of a node, and a procedural interface for modifying these values.
52 function Color (Node : Node_Access) return Color_Type;
53 pragma Inline (Color);
55 function Left (Node : Node_Access) return Node_Access;
58 function Parent (Node : Node_Access) return Node_Access;
59 pragma Inline (Parent);
61 function Right (Node : Node_Access) return Node_Access;
62 pragma Inline (Right);
64 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
65 pragma Inline (Set_Parent);
67 procedure Set_Left (Node : Node_Access; Left : Node_Access);
68 pragma Inline (Set_Left);
70 procedure Set_Right (Node : Node_Access; Right : Node_Access);
71 pragma Inline (Set_Right);
73 procedure Set_Color (Node : Node_Access; Color : Color_Type);
74 pragma Inline (Set_Color);
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 function Copy_Node (Source : Node_Access) return Node_Access;
81 pragma Inline (Copy_Node);
83 procedure Free (X : in out Node_Access);
85 procedure Insert_Sans_Hint
86 (Tree : in out Tree_Type;
87 New_Item : Element_Type;
88 Node : out Node_Access);
90 procedure Insert_With_Hint
91 (Dst_Tree : in out Tree_Type;
92 Dst_Hint : Node_Access;
93 Src_Node : Node_Access;
94 Dst_Node : out Node_Access);
96 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
97 pragma Inline (Is_Equal_Node_Node);
99 function Is_Greater_Element_Node
100 (Left : Element_Type;
101 Right : Node_Access) return Boolean;
102 pragma Inline (Is_Greater_Element_Node);
104 function Is_Less_Element_Node
105 (Left : Element_Type;
106 Right : Node_Access) return Boolean;
107 pragma Inline (Is_Less_Element_Node);
109 function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
110 pragma Inline (Is_Less_Node_Node);
112 procedure Replace_Element
113 (Tree : in out Tree_Type;
115 Item : Element_Type);
117 --------------------------
118 -- Local Instantiations --
119 --------------------------
121 package Tree_Operations is
122 new Red_Black_Trees.Generic_Operations (Tree_Types);
124 procedure Delete_Tree is
125 new Tree_Operations.Generic_Delete_Tree (Free);
127 function Copy_Tree is
128 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
133 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
135 package Element_Keys is
136 new Red_Black_Trees.Generic_Keys
137 (Tree_Operations => Tree_Operations,
138 Key_Type => Element_Type,
139 Is_Less_Key_Node => Is_Less_Element_Node,
140 Is_Greater_Key_Node => Is_Greater_Element_Node);
143 new Generic_Set_Operations
144 (Tree_Operations => Tree_Operations,
145 Insert_With_Hint => Insert_With_Hint,
146 Copy_Tree => Copy_Tree,
147 Delete_Tree => Delete_Tree,
148 Is_Less => Is_Less_Node_Node,
155 function "<" (Left, Right : Cursor) return Boolean is
157 if Left.Node = null then
158 raise Constraint_Error with "Left cursor equals No_Element";
161 if Right.Node = null then
162 raise Constraint_Error with "Right cursor equals No_Element";
165 pragma Assert (Vet (Left.Container.Tree, Left.Node),
166 "bad Left cursor in ""<""");
168 pragma Assert (Vet (Right.Container.Tree, Right.Node),
169 "bad Right cursor in ""<""");
171 return Left.Node.Element < Right.Node.Element;
174 function "<" (Left : Cursor; Right : Element_Type)
177 if Left.Node = null then
178 raise Constraint_Error with "Left cursor equals No_Element";
181 pragma Assert (Vet (Left.Container.Tree, Left.Node),
182 "bad Left cursor in ""<""");
184 return Left.Node.Element < Right;
187 function "<" (Left : Element_Type; Right : Cursor)
190 if Right.Node = null then
191 raise Constraint_Error with "Right cursor equals No_Element";
194 pragma Assert (Vet (Right.Container.Tree, Right.Node),
195 "bad Right cursor in ""<""");
197 return Left < Right.Node.Element;
204 function "=" (Left, Right : Set) return Boolean is
206 return Is_Equal (Left.Tree, Right.Tree);
213 function ">" (Left, Right : Cursor) return Boolean is
215 if Left.Node = null then
216 raise Constraint_Error with "Left cursor equals No_Element";
219 if Right.Node = null then
220 raise Constraint_Error with "Right cursor equals No_Element";
223 pragma Assert (Vet (Left.Container.Tree, Left.Node),
224 "bad Left cursor in "">""");
226 pragma Assert (Vet (Right.Container.Tree, Right.Node),
227 "bad Right cursor in "">""");
229 -- L > R same as R < L
231 return Right.Node.Element < Left.Node.Element;
234 function ">" (Left : Cursor; Right : Element_Type)
237 if Left.Node = null then
238 raise Constraint_Error with "Left cursor equals No_Element";
241 pragma Assert (Vet (Left.Container.Tree, Left.Node),
242 "bad Left cursor in "">""");
244 return Right < Left.Node.Element;
247 function ">" (Left : Element_Type; Right : Cursor)
250 if Right.Node = null then
251 raise Constraint_Error with "Right cursor equals No_Element";
254 pragma Assert (Vet (Right.Container.Tree, Right.Node),
255 "bad Right cursor in "">""");
257 return Right.Node.Element < Left;
264 procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree);
266 procedure Adjust (Container : in out Set) is
268 Adjust (Container.Tree);
275 procedure Assign (Target : in out Set; Source : Set) is
277 if Target'Address = Source'Address then
282 Target.Union (Source);
289 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
290 Node : constant Node_Access :=
291 Element_Keys.Ceiling (Container.Tree, Item);
298 return Cursor'(Container'Unrestricted_Access, Node);
306 new Tree_Operations.Generic_Clear (Delete_Tree);
308 procedure Clear (Container : in out Set) is
310 Clear (Container.Tree);
317 function Color (Node : Node_Access) return Color_Type is
326 function Contains (Container : Set; Item : Element_Type) return Boolean is
328 return Find (Container, Item) /= No_Element;
335 function Copy (Source : Set) return Set is
337 return Target : Set do
338 Target.Assign (Source);
346 function Copy_Node (Source : Node_Access) return Node_Access is
347 Target : constant Node_Access :=
348 new Node_Type'(Parent => null,
351 Color => Source.Color,
352 Element => Source.Element);
361 procedure Delete (Container : in out Set; Item : Element_Type) is
362 Tree : Tree_Type renames Container.Tree;
363 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
364 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
369 raise Constraint_Error with
370 "attempt to delete element not in set";
375 Node := Tree_Operations.Next (Node);
376 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
379 exit when Node = Done;
383 procedure Delete (Container : in out Set; Position : in out Cursor) is
385 if Position.Node = null then
386 raise Constraint_Error with "Position cursor equals No_Element";
389 if Position.Container /= Container'Unrestricted_Access then
390 raise Program_Error with "Position cursor designates wrong set";
393 pragma Assert (Vet (Container.Tree, Position.Node),
394 "bad cursor in Delete");
396 Delete_Node_Sans_Free (Container.Tree, Position.Node);
397 Free (Position.Node);
399 Position.Container := null;
406 procedure Delete_First (Container : in out Set) is
407 Tree : Tree_Type renames Container.Tree;
408 X : Node_Access := Tree.First;
415 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
423 procedure Delete_Last (Container : in out Set) is
424 Tree : Tree_Type renames Container.Tree;
425 X : Node_Access := Tree.Last;
432 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
440 procedure Difference (Target : in out Set; Source : Set) is
442 Set_Ops.Difference (Target.Tree, Source.Tree);
445 function Difference (Left, Right : Set) return Set is
446 Tree : constant Tree_Type :=
447 Set_Ops.Difference (Left.Tree, Right.Tree);
449 return Set'(Controlled with Tree);
456 function Element (Position : Cursor) return Element_Type is
458 if Position.Node = null then
459 raise Constraint_Error with "Position cursor equals No_Element";
462 pragma Assert (Vet (Position.Container.Tree, Position.Node),
463 "bad cursor in Element");
465 return Position.Node.Element;
468 -------------------------
469 -- Equivalent_Elements --
470 -------------------------
472 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
481 end Equivalent_Elements;
483 ---------------------
484 -- Equivalent_Sets --
485 ---------------------
487 function Equivalent_Sets (Left, Right : Set) return Boolean is
489 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
490 pragma Inline (Is_Equivalent_Node_Node);
492 function Is_Equivalent is
493 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
495 -----------------------------
496 -- Is_Equivalent_Node_Node --
497 -----------------------------
499 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
501 if L.Element < R.Element then
503 elsif R.Element < L.Element then
508 end Is_Equivalent_Node_Node;
510 -- Start of processing for Equivalent_Sets
513 return Is_Equivalent (Left.Tree, Right.Tree);
520 procedure Exclude (Container : in out Set; Item : Element_Type) is
521 Tree : Tree_Type renames Container.Tree;
522 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
523 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
526 while Node /= Done loop
528 Node := Tree_Operations.Next (Node);
529 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
538 procedure Finalize (Object : in out Iterator) is
539 B : Natural renames Object.Container.Tree.Busy;
540 pragma Assert (B > 0);
549 function Find (Container : Set; Item : Element_Type) return Cursor is
550 Node : constant Node_Access :=
551 Element_Keys.Find (Container.Tree, Item);
558 return Cursor'(Container'Unrestricted_Access, Node);
565 function First (Container : Set) return Cursor is
567 if Container.Tree.First = null then
571 return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
574 function First (Object : Iterator) return Cursor is
576 -- The value of the iterator object's Node component influences the
577 -- behavior of the First (and Last) selector function.
579 -- When the Node component is null, this means the iterator object was
580 -- constructed without a start expression, in which case the (forward)
581 -- iteration starts from the (logical) beginning of the entire sequence
582 -- of items (corresponding to Container.First, for a forward iterator).
584 -- Otherwise, this is iteration over a partial sequence of items. When
585 -- the Node component is non-null, the iterator object was constructed
586 -- with a start expression, that specifies the position from which the
587 -- (forward) partial iteration begins.
589 if Object.Node = null then
590 return Object.Container.First;
592 return Cursor'(Object.Container, Object.Node);
600 function First_Element (Container : Set) return Element_Type is
602 if Container.Tree.First = null then
603 raise Constraint_Error with "set is empty";
606 return Container.Tree.First.Element;
613 function Floor (Container : Set; Item : Element_Type) return Cursor is
614 Node : constant Node_Access :=
615 Element_Keys.Floor (Container.Tree, Item);
622 return Cursor'(Container'Unrestricted_Access, Node);
629 procedure Free (X : in out Node_Access) is
630 procedure Deallocate is
631 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
647 package body Generic_Keys is
649 -----------------------
650 -- Local Subprograms --
651 -----------------------
653 function Is_Greater_Key_Node
655 Right : Node_Access) return Boolean;
656 pragma Inline (Is_Greater_Key_Node);
658 function Is_Less_Key_Node
660 Right : Node_Access) return Boolean;
661 pragma Inline (Is_Less_Key_Node);
663 --------------------------
664 -- Local_Instantiations --
665 --------------------------
668 new Red_Black_Trees.Generic_Keys
669 (Tree_Operations => Tree_Operations,
670 Key_Type => Key_Type,
671 Is_Less_Key_Node => Is_Less_Key_Node,
672 Is_Greater_Key_Node => Is_Greater_Key_Node);
678 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
679 Node : constant Node_Access :=
680 Key_Keys.Ceiling (Container.Tree, Key);
687 return Cursor'(Container'Unrestricted_Access, Node);
694 function Contains (Container : Set; Key : Key_Type) return Boolean is
696 return Find (Container, Key) /= No_Element;
703 procedure Delete (Container : in out Set; Key : Key_Type) is
704 Tree : Tree_Type renames Container.Tree;
705 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
706 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
711 raise Constraint_Error with "attempt to delete key not in set";
716 Node := Tree_Operations.Next (Node);
717 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
720 exit when Node = Done;
728 function Element (Container : Set; Key : Key_Type) return Element_Type is
729 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
732 raise Constraint_Error with "key not in set";
738 ---------------------
739 -- Equivalent_Keys --
740 ---------------------
742 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
757 procedure Exclude (Container : in out Set; Key : Key_Type) is
758 Tree : Tree_Type renames Container.Tree;
759 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
760 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
764 while Node /= Done loop
766 Node := Tree_Operations.Next (Node);
767 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
776 function Find (Container : Set; Key : Key_Type) return Cursor is
777 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
784 return Cursor'(Container'Unrestricted_Access, Node);
791 function Floor (Container : Set; Key : Key_Type) return Cursor is
792 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
799 return Cursor'(Container'Unrestricted_Access, Node);
802 -------------------------
803 -- Is_Greater_Key_Node --
804 -------------------------
806 function Is_Greater_Key_Node
808 Right : Node_Access) return Boolean is
810 return Key (Right.Element) < 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 is
821 return Left < Key (Right.Element);
822 end Is_Less_Key_Node;
831 Process : not null access procedure (Position : Cursor))
833 procedure Process_Node (Node : Node_Access);
834 pragma Inline (Process_Node);
836 procedure Local_Iterate is
837 new Key_Keys.Generic_Iteration (Process_Node);
843 procedure Process_Node (Node : Node_Access) is
845 Process (Cursor'(Container'Unrestricted_Access, Node));
848 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
849 B : Natural renames T.Busy;
851 -- Start of processing for Iterate
857 Local_Iterate (T, Key);
871 function Key (Position : Cursor) return Key_Type is
873 if Position.Node = null then
874 raise Constraint_Error with
875 "Position cursor equals No_Element";
878 pragma Assert (Vet (Position.Container.Tree, Position.Node),
879 "bad cursor in Key");
881 return Key (Position.Node.Element);
884 ---------------------
885 -- Reverse_Iterate --
886 ---------------------
888 procedure Reverse_Iterate
891 Process : not null access procedure (Position : Cursor))
893 procedure Process_Node (Node : Node_Access);
894 pragma Inline (Process_Node);
896 procedure Local_Reverse_Iterate is
897 new Key_Keys.Generic_Reverse_Iteration (Process_Node);
903 procedure Process_Node (Node : Node_Access) is
905 Process (Cursor'(Container'Unrestricted_Access, Node));
908 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
909 B : Natural renames T.Busy;
911 -- Start of processing for Reverse_Iterate
917 Local_Reverse_Iterate (T, Key);
931 procedure Update_Element
932 (Container : in out Set;
934 Process : not null access procedure (Element : in out Element_Type))
936 Tree : Tree_Type renames Container.Tree;
937 Node : constant Node_Access := Position.Node;
941 raise Constraint_Error with
942 "Position cursor equals No_Element";
945 if Position.Container /= Container'Unrestricted_Access then
946 raise Program_Error with
947 "Position cursor designates wrong set";
950 pragma Assert (Vet (Tree, Node),
951 "bad cursor in Update_Element");
954 E : Element_Type renames Node.Element;
955 K : constant Key_Type := Key (E);
957 B : Natural renames Tree.Busy;
958 L : Natural renames Tree.Lock;
976 if Equivalent_Keys (Left => K, Right => Key (E)) then
981 -- Delete_Node checks busy-bit
983 Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
985 Insert_New_Item : declare
986 function New_Node return Node_Access;
987 pragma Inline (New_Node);
989 procedure Insert_Post is
990 new Element_Keys.Generic_Insert_Post (New_Node);
992 procedure Unconditional_Insert is
993 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
999 function New_Node return Node_Access is
1001 Node.Color := Red_Black_Trees.Red;
1002 Node.Parent := null;
1009 Result : Node_Access;
1011 -- Start of processing for Insert_New_Item
1014 Unconditional_Insert
1016 Key => Node.Element,
1019 pragma Assert (Result = Node);
1020 end Insert_New_Item;
1029 function Has_Element (Position : Cursor) return Boolean is
1031 return Position /= No_Element;
1038 procedure Insert (Container : in out Set; New_Item : Element_Type) is
1040 pragma Unreferenced (Position);
1042 Insert (Container, New_Item, Position);
1046 (Container : in out Set;
1047 New_Item : Element_Type;
1048 Position : out Cursor)
1051 Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
1052 Position.Container := Container'Unrestricted_Access;
1055 ----------------------
1056 -- Insert_Sans_Hint --
1057 ----------------------
1059 procedure Insert_Sans_Hint
1060 (Tree : in out Tree_Type;
1061 New_Item : Element_Type;
1062 Node : out Node_Access)
1064 function New_Node return Node_Access;
1065 pragma Inline (New_Node);
1067 procedure Insert_Post is
1068 new Element_Keys.Generic_Insert_Post (New_Node);
1070 procedure Unconditional_Insert is
1071 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1077 function New_Node return Node_Access is
1078 Node : constant Node_Access :=
1079 new Node_Type'(Parent => null,
1082 Color => Red_Black_Trees.Red,
1083 Element => New_Item);
1088 -- Start of processing for Insert_Sans_Hint
1091 Unconditional_Insert (Tree, New_Item, Node);
1092 end Insert_Sans_Hint;
1094 ----------------------
1095 -- Insert_With_Hint --
1096 ----------------------
1098 procedure Insert_With_Hint
1099 (Dst_Tree : in out Tree_Type;
1100 Dst_Hint : Node_Access;
1101 Src_Node : Node_Access;
1102 Dst_Node : out Node_Access)
1104 function New_Node return Node_Access;
1105 pragma Inline (New_Node);
1107 procedure Insert_Post is
1108 new Element_Keys.Generic_Insert_Post (New_Node);
1110 procedure Insert_Sans_Hint is
1111 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1113 procedure Local_Insert_With_Hint is
1114 new Element_Keys.Generic_Unconditional_Insert_With_Hint
1122 function New_Node return Node_Access is
1123 Node : constant Node_Access :=
1124 new Node_Type'(Parent => null,
1128 Element => Src_Node.Element);
1133 -- Start of processing for Insert_With_Hint
1136 Local_Insert_With_Hint
1141 end Insert_With_Hint;
1147 procedure Intersection (Target : in out Set; Source : Set) is
1149 Set_Ops.Intersection (Target.Tree, Source.Tree);
1152 function Intersection (Left, Right : Set) return Set is
1153 Tree : constant Tree_Type :=
1154 Set_Ops.Intersection (Left.Tree, Right.Tree);
1156 return Set'(Controlled with Tree);
1163 function Is_Empty (Container : Set) return Boolean is
1165 return Container.Tree.Length = 0;
1168 ------------------------
1169 -- Is_Equal_Node_Node --
1170 ------------------------
1172 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1174 return L.Element = R.Element;
1175 end Is_Equal_Node_Node;
1177 -----------------------------
1178 -- Is_Greater_Element_Node --
1179 -----------------------------
1181 function Is_Greater_Element_Node
1182 (Left : Element_Type;
1183 Right : Node_Access) return Boolean
1186 -- e > node same as node < e
1188 return Right.Element < Left;
1189 end Is_Greater_Element_Node;
1191 --------------------------
1192 -- Is_Less_Element_Node --
1193 --------------------------
1195 function Is_Less_Element_Node
1196 (Left : Element_Type;
1197 Right : Node_Access) return Boolean
1200 return Left < Right.Element;
1201 end Is_Less_Element_Node;
1203 -----------------------
1204 -- Is_Less_Node_Node --
1205 -----------------------
1207 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1209 return L.Element < R.Element;
1210 end Is_Less_Node_Node;
1216 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1218 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1227 Process : not null access procedure (Position : Cursor))
1229 procedure Process_Node (Node : Node_Access);
1230 pragma Inline (Process_Node);
1232 procedure Local_Iterate is
1233 new Tree_Operations.Generic_Iteration (Process_Node);
1239 procedure Process_Node (Node : Node_Access) is
1241 Process (Cursor'(Container'Unrestricted_Access, Node));
1244 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1245 B : Natural renames T.Busy;
1247 -- Start of processing for Iterate
1265 Item : Element_Type;
1266 Process : not null access procedure (Position : Cursor))
1268 procedure Process_Node (Node : Node_Access);
1269 pragma Inline (Process_Node);
1271 procedure Local_Iterate is
1272 new Element_Keys.Generic_Iteration (Process_Node);
1278 procedure Process_Node (Node : Node_Access) is
1280 Process (Cursor'(Container'Unrestricted_Access, Node));
1283 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1284 B : Natural renames T.Busy;
1286 -- Start of processing for Iterate
1292 Local_Iterate (T, Item);
1302 function Iterate (Container : Set)
1303 return Set_Iterator_Interfaces.Reversible_Iterator'Class
1305 S : constant Set_Access := Container'Unrestricted_Access;
1306 B : Natural renames S.Tree.Busy;
1309 -- The value of the Node component influences the behavior of the First
1310 -- and Last selector functions of the iterator object. When the Node
1311 -- component is null (as is the case here), this means the iterator
1312 -- object was constructed without a start expression. This is a complete
1313 -- iterator, meaning that the iteration starts from the (logical)
1314 -- beginning of the sequence of items.
1316 -- Note: For a forward iterator, Container.First is the beginning, and
1317 -- for a reverse iterator, Container.Last is the beginning.
1319 return It : constant Iterator := (Limited_Controlled with S, null) do
1324 function Iterate (Container : Set; Start : Cursor)
1325 return Set_Iterator_Interfaces.Reversible_Iterator'Class
1327 S : constant Set_Access := Container'Unrestricted_Access;
1328 B : Natural renames S.Tree.Busy;
1331 -- It was formerly the case that when Start = No_Element, the partial
1332 -- iterator was defined to behave the same as for a complete iterator,
1333 -- and iterate over the entire sequence of items. However, those
1334 -- semantics were unintuitive and arguably error-prone (it is too easy
1335 -- to accidentally create an endless loop), and so they were changed,
1336 -- per the ARG meeting in Denver on 2011/11. However, there was no
1337 -- consensus about what positive meaning this corner case should have,
1338 -- and so it was decided to simply raise an exception. This does imply,
1339 -- however, that it is not possible to use a partial iterator to specify
1340 -- an empty sequence of items.
1342 if Start = No_Element then
1343 raise Constraint_Error with
1344 "Start position for iterator equals No_Element";
1347 if Start.Container /= Container'Unrestricted_Access then
1348 raise Program_Error with
1349 "Start cursor of Iterate designates wrong set";
1352 pragma Assert (Vet (Container.Tree, Start.Node),
1353 "Start cursor of Iterate is bad");
1355 -- The value of the Node component influences the behavior of the First
1356 -- and Last selector functions of the iterator object. When the Node
1357 -- component is non-null (as is the case here), it means that this is a
1358 -- partial iteration, over a subset of the complete sequence of
1359 -- items. The iterator object was constructed with a start expression,
1360 -- indicating the position from which the iteration begins. Note that
1361 -- the start position has the same value irrespective of whether this is
1362 -- a forward or reverse iteration.
1364 return It : constant Iterator :=
1365 (Limited_Controlled with S, Start.Node)
1375 function Last (Container : Set) return Cursor is
1377 if Container.Tree.Last = null then
1381 return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1384 function Last (Object : Iterator) return Cursor is
1386 -- The value of the iterator object's Node component influences the
1387 -- behavior of the Last (and First) selector function.
1389 -- When the Node component is null, this means the iterator object was
1390 -- constructed without a start expression, in which case the (reverse)
1391 -- iteration starts from the (logical) beginning of the entire sequence
1392 -- (corresponding to Container.Last, for a reverse iterator).
1394 -- Otherwise, this is iteration over a partial sequence of items. When
1395 -- the Node component is non-null, the iterator object was constructed
1396 -- with a start expression, that specifies the position from which the
1397 -- (reverse) partial iteration begins.
1399 if Object.Node = null then
1400 return Object.Container.Last;
1402 return Cursor'(Object.Container, Object.Node);
1410 function Last_Element (Container : Set) return Element_Type is
1412 if Container.Tree.Last = null then
1413 raise Constraint_Error with "set is empty";
1416 return Container.Tree.Last.Element;
1423 function Left (Node : Node_Access) return Node_Access is
1432 function Length (Container : Set) return Count_Type is
1434 return Container.Tree.Length;
1442 new Tree_Operations.Generic_Move (Clear);
1444 procedure Move (Target : in out Set; Source : in out Set) is
1446 Move (Target => Target.Tree, Source => Source.Tree);
1453 procedure Next (Position : in out Cursor)
1456 Position := Next (Position);
1459 function Next (Position : Cursor) return Cursor is
1461 if Position = No_Element then
1465 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1466 "bad cursor in Next");
1469 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
1475 return Cursor'(Position.Container, Node);
1479 function Next (Object : Iterator; Position : Cursor) return Cursor is
1481 if Position.Container = null then
1485 if Position.Container /= Object.Container then
1486 raise Program_Error with
1487 "Position cursor of Next designates wrong set";
1490 return Next (Position);
1497 function Overlap (Left, Right : Set) return Boolean is
1499 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1506 function Parent (Node : Node_Access) return Node_Access is
1515 procedure Previous (Position : in out Cursor)
1518 Position := Previous (Position);
1521 function Previous (Position : Cursor) return Cursor is
1523 if Position = No_Element then
1527 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1528 "bad cursor in Previous");
1531 Node : constant Node_Access :=
1532 Tree_Operations.Previous (Position.Node);
1534 return (if Node = null then No_Element
1535 else Cursor'(Position.Container, Node));
1539 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1541 if Position.Container = null then
1545 if Position.Container /= Object.Container then
1546 raise Program_Error with
1547 "Position cursor of Previous designates wrong set";
1550 return Previous (Position);
1557 procedure Query_Element
1559 Process : not null access procedure (Element : Element_Type))
1562 if Position.Node = null then
1563 raise Constraint_Error with "Position cursor equals No_Element";
1566 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1567 "bad cursor in Query_Element");
1570 T : Tree_Type renames Position.Container.Tree;
1572 B : Natural renames T.Busy;
1573 L : Natural renames T.Lock;
1580 Process (Position.Node.Element);
1598 (Stream : not null access Root_Stream_Type'Class;
1599 Container : out Set)
1602 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1603 pragma Inline (Read_Node);
1606 new Tree_Operations.Generic_Read (Clear, Read_Node);
1613 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1615 Node : Node_Access := new Node_Type;
1617 Element_Type'Read (Stream, Node.Element);
1621 Free (Node); -- Note that Free deallocates elem too
1625 -- Start of processing for Read
1628 Read (Stream, Container.Tree);
1632 (Stream : not null access Root_Stream_Type'Class;
1636 raise Program_Error with "attempt to stream set cursor";
1639 ---------------------
1640 -- Replace_Element --
1641 ---------------------
1643 procedure Replace_Element
1644 (Tree : in out Tree_Type;
1646 Item : Element_Type)
1649 if Item < Node.Element
1650 or else Node.Element < Item
1654 if Tree.Lock > 0 then
1655 raise Program_Error with
1656 "attempt to tamper with elements (set is locked)";
1659 Node.Element := Item;
1663 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
1665 Insert_New_Item : declare
1666 function New_Node return Node_Access;
1667 pragma Inline (New_Node);
1669 procedure Insert_Post is
1670 new Element_Keys.Generic_Insert_Post (New_Node);
1672 procedure Unconditional_Insert is
1673 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1679 function New_Node return Node_Access is
1681 Node.Element := Item;
1682 Node.Color := Red_Black_Trees.Red;
1683 Node.Parent := null;
1690 Result : Node_Access;
1692 -- Start of processing for Insert_New_Item
1695 Unconditional_Insert
1700 pragma Assert (Result = Node);
1701 end Insert_New_Item;
1702 end Replace_Element;
1704 procedure Replace_Element
1705 (Container : in out Set;
1707 New_Item : Element_Type)
1710 if Position.Node = null then
1711 raise Constraint_Error with
1712 "Position cursor equals No_Element";
1715 if Position.Container /= Container'Unrestricted_Access then
1716 raise Program_Error with
1717 "Position cursor designates wrong set";
1720 pragma Assert (Vet (Container.Tree, Position.Node),
1721 "bad cursor in Replace_Element");
1723 Replace_Element (Container.Tree, Position.Node, New_Item);
1724 end Replace_Element;
1726 ---------------------
1727 -- Reverse_Iterate --
1728 ---------------------
1730 procedure Reverse_Iterate
1732 Process : not null access procedure (Position : Cursor))
1734 procedure Process_Node (Node : Node_Access);
1735 pragma Inline (Process_Node);
1737 procedure Local_Reverse_Iterate is
1738 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1744 procedure Process_Node (Node : Node_Access) is
1746 Process (Cursor'(Container'Unrestricted_Access, Node));
1749 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1750 B : Natural renames T.Busy;
1752 -- Start of processing for Reverse_Iterate
1758 Local_Reverse_Iterate (T);
1766 end Reverse_Iterate;
1768 procedure Reverse_Iterate
1770 Item : Element_Type;
1771 Process : not null access procedure (Position : Cursor))
1773 procedure Process_Node (Node : Node_Access);
1774 pragma Inline (Process_Node);
1776 procedure Local_Reverse_Iterate is
1777 new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1783 procedure Process_Node (Node : Node_Access) is
1785 Process (Cursor'(Container'Unrestricted_Access, Node));
1788 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1789 B : Natural renames T.Busy;
1791 -- Start of processing for Reverse_Iterate
1797 Local_Reverse_Iterate (T, Item);
1805 end Reverse_Iterate;
1811 function Right (Node : Node_Access) return Node_Access is
1820 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1822 Node.Color := Color;
1829 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1838 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1840 Node.Parent := Parent;
1847 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1849 Node.Right := Right;
1852 --------------------------
1853 -- Symmetric_Difference --
1854 --------------------------
1856 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1858 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1859 end Symmetric_Difference;
1861 function Symmetric_Difference (Left, Right : Set) return Set is
1862 Tree : constant Tree_Type :=
1863 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1865 return Set'(Controlled with Tree);
1866 end Symmetric_Difference;
1872 function To_Set (New_Item : Element_Type) return Set is
1875 pragma Unreferenced (Node);
1877 Insert_Sans_Hint (Tree, New_Item, Node);
1878 return Set'(Controlled with Tree);
1885 procedure Union (Target : in out Set; Source : Set) is
1887 Set_Ops.Union (Target.Tree, Source.Tree);
1890 function Union (Left, Right : Set) return Set is
1891 Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
1893 return Set'(Controlled with Tree);
1901 (Stream : not null access Root_Stream_Type'Class;
1904 procedure Write_Node
1905 (Stream : not null access Root_Stream_Type'Class;
1906 Node : Node_Access);
1907 pragma Inline (Write_Node);
1910 new Tree_Operations.Generic_Write (Write_Node);
1916 procedure Write_Node
1917 (Stream : not null access Root_Stream_Type'Class;
1921 Element_Type'Write (Stream, Node.Element);
1924 -- Start of processing for Write
1927 Write (Stream, Container.Tree);
1931 (Stream : not null access Root_Stream_Type'Class;
1935 raise Program_Error with "attempt to stream set cursor";
1938 end Ada.Containers.Ordered_Multisets;