1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS --
9 -- Copyright (C) 2004-2014, 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.Containers.Red_Black_Trees.Generic_Operations;
31 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
33 with Ada.Containers.Red_Black_Trees.Generic_Keys;
34 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
36 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
37 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
39 with Ada.Unchecked_Deallocation;
41 with System; use type System.Address;
43 package body Ada.Containers.Indefinite_Ordered_Sets is
45 pragma Annotate (CodePeer, Skip_Analysis);
47 -----------------------
48 -- Local Subprograms --
49 -----------------------
51 function Color (Node : Node_Access) return Color_Type;
52 pragma Inline (Color);
54 function Copy_Node (Source : Node_Access) return Node_Access;
55 pragma Inline (Copy_Node);
57 procedure Free (X : in out Node_Access);
59 procedure Insert_Sans_Hint
60 (Tree : in out Tree_Type;
61 New_Item : Element_Type;
62 Node : out Node_Access;
63 Inserted : out Boolean);
65 procedure Insert_With_Hint
66 (Dst_Tree : in out Tree_Type;
67 Dst_Hint : Node_Access;
68 Src_Node : Node_Access;
69 Dst_Node : out Node_Access);
71 function Is_Greater_Element_Node
73 Right : Node_Access) return Boolean;
74 pragma Inline (Is_Greater_Element_Node);
76 function Is_Less_Element_Node
78 Right : Node_Access) return Boolean;
79 pragma Inline (Is_Less_Element_Node);
81 function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
82 pragma Inline (Is_Less_Node_Node);
84 function Left (Node : Node_Access) return Node_Access;
87 function Parent (Node : Node_Access) return Node_Access;
88 pragma Inline (Parent);
90 procedure Replace_Element
91 (Tree : in out Tree_Type;
95 function Right (Node : Node_Access) return Node_Access;
96 pragma Inline (Right);
98 procedure Set_Color (Node : Node_Access; Color : Color_Type);
99 pragma Inline (Set_Color);
101 procedure Set_Left (Node : Node_Access; Left : Node_Access);
102 pragma Inline (Set_Left);
104 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
105 pragma Inline (Set_Parent);
107 procedure Set_Right (Node : Node_Access; Right : Node_Access);
108 pragma Inline (Set_Right);
110 --------------------------
111 -- Local Instantiations --
112 --------------------------
114 procedure Free_Element is
115 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
117 package Tree_Operations is
118 new Red_Black_Trees.Generic_Operations (Tree_Types);
120 procedure Delete_Tree is
121 new Tree_Operations.Generic_Delete_Tree (Free);
123 function Copy_Tree is
124 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
128 package Element_Keys is
129 new Red_Black_Trees.Generic_Keys
130 (Tree_Operations => Tree_Operations,
131 Key_Type => Element_Type,
132 Is_Less_Key_Node => Is_Less_Element_Node,
133 Is_Greater_Key_Node => Is_Greater_Element_Node);
136 new Generic_Set_Operations
137 (Tree_Operations => Tree_Operations,
138 Insert_With_Hint => Insert_With_Hint,
139 Copy_Tree => Copy_Tree,
140 Delete_Tree => Delete_Tree,
141 Is_Less => Is_Less_Node_Node,
148 function "<" (Left, Right : Cursor) return Boolean is
150 if Left.Node = null then
151 raise Constraint_Error with "Left cursor equals No_Element";
154 if Right.Node = null then
155 raise Constraint_Error with "Right cursor equals No_Element";
158 if Left.Node.Element = null then
159 raise Program_Error with "Left cursor is bad";
162 if Right.Node.Element = null then
163 raise Program_Error with "Right cursor is bad";
166 pragma Assert (Vet (Left.Container.Tree, Left.Node),
167 "bad Left cursor in ""<""");
169 pragma Assert (Vet (Right.Container.Tree, Right.Node),
170 "bad Right cursor in ""<""");
172 return Left.Node.Element.all < Right.Node.Element.all;
175 function "<" (Left : Cursor; Right : Element_Type) return Boolean is
177 if Left.Node = null then
178 raise Constraint_Error with "Left cursor equals No_Element";
181 if Left.Node.Element = null then
182 raise Program_Error with "Left cursor is bad";
185 pragma Assert (Vet (Left.Container.Tree, Left.Node),
186 "bad Left cursor in ""<""");
188 return Left.Node.Element.all < Right;
191 function "<" (Left : Element_Type; Right : Cursor) return Boolean is
193 if Right.Node = null then
194 raise Constraint_Error with "Right cursor equals No_Element";
197 if Right.Node.Element = null then
198 raise Program_Error with "Right cursor is bad";
201 pragma Assert (Vet (Right.Container.Tree, Right.Node),
202 "bad Right cursor in ""<""");
204 return Left < Right.Node.Element.all;
211 function "=" (Left, Right : Set) return Boolean is
213 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
214 pragma Inline (Is_Equal_Node_Node);
217 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
219 ------------------------
220 -- Is_Equal_Node_Node --
221 ------------------------
223 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
225 return L.Element.all = R.Element.all;
226 end Is_Equal_Node_Node;
228 -- Start of processing for "="
231 return Is_Equal (Left.Tree, Right.Tree);
238 function ">" (Left, Right : Cursor) return Boolean is
240 if Left.Node = null then
241 raise Constraint_Error with "Left cursor equals No_Element";
244 if Right.Node = null then
245 raise Constraint_Error with "Right cursor equals No_Element";
248 if Left.Node.Element = null then
249 raise Program_Error with "Left cursor is bad";
252 if Right.Node.Element = null then
253 raise Program_Error with "Right cursor is bad";
256 pragma Assert (Vet (Left.Container.Tree, Left.Node),
257 "bad Left cursor in "">""");
259 pragma Assert (Vet (Right.Container.Tree, Right.Node),
260 "bad Right cursor in "">""");
262 -- L > R same as R < L
264 return Right.Node.Element.all < Left.Node.Element.all;
267 function ">" (Left : Cursor; Right : Element_Type) return Boolean is
269 if Left.Node = null then
270 raise Constraint_Error with "Left cursor equals No_Element";
273 if Left.Node.Element = null then
274 raise Program_Error with "Left cursor is bad";
277 pragma Assert (Vet (Left.Container.Tree, Left.Node),
278 "bad Left cursor in "">""");
280 return Right < Left.Node.Element.all;
283 function ">" (Left : Element_Type; Right : Cursor) return Boolean is
285 if Right.Node = null then
286 raise Constraint_Error with "Right cursor equals No_Element";
289 if Right.Node.Element = null then
290 raise Program_Error with "Right cursor is bad";
293 pragma Assert (Vet (Right.Container.Tree, Right.Node),
294 "bad Right cursor in "">""");
296 return Right.Node.Element.all < Left;
303 procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree);
305 procedure Adjust (Container : in out Set) is
307 Adjust (Container.Tree);
310 procedure Adjust (Control : in out Reference_Control_Type) is
312 if Control.Container /= null then
314 Tree : Tree_Type renames Control.Container.all.Tree;
315 B : Natural renames Tree.Busy;
316 L : Natural renames Tree.Lock;
328 procedure Assign (Target : in out Set; Source : Set) is
330 if Target'Address = Source'Address then
335 Target.Union (Source);
342 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
343 Node : constant Node_Access :=
344 Element_Keys.Ceiling (Container.Tree, Item);
346 return (if Node = null then No_Element
347 else Cursor'(Container'Unrestricted_Access, Node));
355 new Tree_Operations.Generic_Clear (Delete_Tree);
357 procedure Clear (Container : in out Set) is
359 Clear (Container.Tree);
366 function Color (Node : Node_Access) return Color_Type is
371 ------------------------
372 -- Constant_Reference --
373 ------------------------
375 function Constant_Reference
376 (Container : aliased Set;
377 Position : Cursor) return Constant_Reference_Type
380 if Position.Container = null then
381 raise Constraint_Error with "Position cursor has no element";
384 if Position.Container /= Container'Unrestricted_Access then
385 raise Program_Error with
386 "Position cursor designates wrong container";
389 if Position.Node.Element = null then
390 raise Program_Error with "Node has no element";
394 (Vet (Container.Tree, Position.Node),
395 "bad cursor in Constant_Reference");
398 Tree : Tree_Type renames Position.Container.all.Tree;
399 B : Natural renames Tree.Busy;
400 L : Natural renames Tree.Lock;
402 return R : constant Constant_Reference_Type :=
403 (Element => Position.Node.Element.all'Access,
404 Control => (Controlled with Container'Unrestricted_Access))
410 end Constant_Reference;
416 function Contains (Container : Set; Item : Element_Type) return Boolean is
418 return Find (Container, Item) /= No_Element;
425 function Copy (Source : Set) return Set is
427 return Target : Set do
428 Target.Assign (Source);
436 function Copy_Node (Source : Node_Access) return Node_Access is
437 Element : Element_Access := new Element_Type'(Source.Element.all);
440 return new Node_Type'(Parent => null,
443 Color => Source.Color,
448 Free_Element (Element);
456 procedure Delete (Container : in out Set; Position : in out Cursor) is
458 if Position.Node = null then
459 raise Constraint_Error with "Position cursor equals No_Element";
462 if Position.Node.Element = null then
463 raise Program_Error with "Position cursor is bad";
466 if Position.Container /= Container'Unrestricted_Access then
467 raise Program_Error with "Position cursor designates wrong set";
470 pragma Assert (Vet (Container.Tree, Position.Node),
471 "bad cursor in Delete");
473 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
474 Free (Position.Node);
475 Position.Container := null;
478 procedure Delete (Container : in out Set; Item : Element_Type) is
479 X : Node_Access := Element_Keys.Find (Container.Tree, Item);
482 raise Constraint_Error with "attempt to delete element not in set";
484 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
493 procedure Delete_First (Container : in out Set) is
494 Tree : Tree_Type renames Container.Tree;
495 X : Node_Access := Tree.First;
498 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
507 procedure Delete_Last (Container : in out Set) is
508 Tree : Tree_Type renames Container.Tree;
509 X : Node_Access := Tree.Last;
512 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
521 procedure Difference (Target : in out Set; Source : Set) is
523 Set_Ops.Difference (Target.Tree, Source.Tree);
526 function Difference (Left, Right : Set) return Set is
527 Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree);
529 return Set'(Controlled with Tree);
536 function Element (Position : Cursor) return Element_Type is
538 if Position.Node = null then
539 raise Constraint_Error with "Position cursor equals No_Element";
542 if Position.Node.Element = null then
543 raise Program_Error with "Position cursor is bad";
546 pragma Assert (Vet (Position.Container.Tree, Position.Node),
547 "bad cursor in Element");
549 return Position.Node.Element.all;
552 -------------------------
553 -- Equivalent_Elements --
554 -------------------------
556 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
558 if Left < Right or else Right < Left then
563 end Equivalent_Elements;
565 ---------------------
566 -- Equivalent_Sets --
567 ---------------------
569 function Equivalent_Sets (Left, Right : Set) return Boolean is
571 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
572 pragma Inline (Is_Equivalent_Node_Node);
574 function Is_Equivalent is
575 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
577 -----------------------------
578 -- Is_Equivalent_Node_Node --
579 -----------------------------
581 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
583 if L.Element.all < R.Element.all then
585 elsif R.Element.all < L.Element.all then
590 end Is_Equivalent_Node_Node;
592 -- Start of processing for Equivalent_Sets
595 return Is_Equivalent (Left.Tree, Right.Tree);
602 procedure Exclude (Container : in out Set; Item : Element_Type) is
603 X : Node_Access := Element_Keys.Find (Container.Tree, Item);
606 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
615 procedure Finalize (Object : in out Iterator) is
617 if Object.Container /= null then
619 B : Natural renames Object.Container.all.Tree.Busy;
626 procedure Finalize (Control : in out Reference_Control_Type) is
628 if Control.Container /= null then
630 Tree : Tree_Type renames Control.Container.all.Tree;
631 B : Natural renames Tree.Busy;
632 L : Natural renames Tree.Lock;
638 Control.Container := null;
646 function Find (Container : Set; Item : Element_Type) return Cursor is
647 Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item);
652 return Cursor'(Container'Unrestricted_Access, Node);
660 function First (Container : Set) return Cursor is
663 (if Container.Tree.First = null then No_Element
664 else Cursor'(Container'Unrestricted_Access, Container.Tree.First));
667 function First (Object : Iterator) return Cursor is
669 -- The value of the iterator object's Node component influences the
670 -- behavior of the First (and Last) selector function.
672 -- When the Node component is null, this means the iterator object was
673 -- constructed without a start expression, in which case the (forward)
674 -- iteration starts from the (logical) beginning of the entire sequence
675 -- of items (corresponding to Container.First, for a forward iterator).
677 -- Otherwise, this is iteration over a partial sequence of items. When
678 -- the Node component is non-null, the iterator object was constructed
679 -- with a start expression, that specifies the position from which the
680 -- (forward) partial iteration begins.
682 if Object.Node = null then
683 return Object.Container.First;
685 return Cursor'(Object.Container, Object.Node);
693 function First_Element (Container : Set) return Element_Type is
695 if Container.Tree.First = null then
696 raise Constraint_Error with "set is empty";
698 return Container.Tree.First.Element.all;
706 function Floor (Container : Set; Item : Element_Type) return Cursor is
707 Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item);
709 return (if Node = null then No_Element
710 else Cursor'(Container'Unrestricted_Access, Node));
717 procedure Free (X : in out Node_Access) is
718 procedure Deallocate is
719 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
731 Free_Element (X.Element);
746 package body Generic_Keys is
748 -----------------------
749 -- Local Subprograms --
750 -----------------------
752 function Is_Greater_Key_Node
754 Right : Node_Access) return Boolean;
755 pragma Inline (Is_Greater_Key_Node);
757 function Is_Less_Key_Node
759 Right : Node_Access) return Boolean;
760 pragma Inline (Is_Less_Key_Node);
762 --------------------------
763 -- Local Instantiations --
764 --------------------------
767 new Red_Black_Trees.Generic_Keys
768 (Tree_Operations => Tree_Operations,
769 Key_Type => Key_Type,
770 Is_Less_Key_Node => Is_Less_Key_Node,
771 Is_Greater_Key_Node => Is_Greater_Key_Node);
777 procedure Adjust (Control : in out Reference_Control_Type) is
779 if Control.Container /= null then
781 Tree : Tree_Type renames Control.Container.Tree;
782 B : Natural renames Tree.Busy;
783 L : Natural renames Tree.Lock;
795 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
796 Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key);
798 return (if Node = null then No_Element
799 else Cursor'(Container'Unrestricted_Access, Node));
802 ------------------------
803 -- Constant_Reference --
804 ------------------------
806 function Constant_Reference
807 (Container : aliased Set;
808 Key : Key_Type) return Constant_Reference_Type
810 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
814 raise Constraint_Error with "Key not in set";
817 if Node.Element = null then
818 raise Program_Error with "Node has no element";
822 Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
823 B : Natural renames Tree.Busy;
824 L : Natural renames Tree.Lock;
826 return R : constant Constant_Reference_Type :=
827 (Element => Node.Element.all'Access,
828 Control => (Controlled with Container'Unrestricted_Access))
834 end Constant_Reference;
840 function Contains (Container : Set; Key : Key_Type) return Boolean is
842 return Find (Container, Key) /= No_Element;
849 procedure Delete (Container : in out Set; Key : Key_Type) is
850 X : Node_Access := Key_Keys.Find (Container.Tree, Key);
854 raise Constraint_Error with "attempt to delete key not in set";
857 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
865 function Element (Container : Set; Key : Key_Type) return Element_Type is
866 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
869 raise Constraint_Error with "key not in set";
871 return Node.Element.all;
875 ---------------------
876 -- Equivalent_Keys --
877 ---------------------
879 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
881 if Left < Right or else Right < Left then
892 procedure Exclude (Container : in out Set; Key : Key_Type) is
893 X : Node_Access := Key_Keys.Find (Container.Tree, Key);
896 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
905 procedure Finalize (Control : in out Reference_Control_Type) is
907 if Control.Container /= null then
909 Tree : Tree_Type renames Control.Container.Tree;
910 B : Natural renames Tree.Busy;
911 L : Natural renames Tree.Lock;
917 if not (Key (Control.Pos) = Control.Old_Key.all) then
918 Delete (Control.Container.all, Key (Control.Pos));
922 Control.Container := null;
923 Control.Old_Key := null;
931 function Find (Container : Set; Key : Key_Type) return Cursor is
932 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
934 return (if Node = null then No_Element
935 else Cursor'(Container'Unrestricted_Access, Node));
942 function Floor (Container : Set; Key : Key_Type) return Cursor is
943 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
945 return (if Node = null then No_Element
946 else Cursor'(Container'Unrestricted_Access, Node));
949 -------------------------
950 -- Is_Greater_Key_Node --
951 -------------------------
953 function Is_Greater_Key_Node
955 Right : Node_Access) return Boolean
958 return Key (Right.Element.all) < Left;
959 end Is_Greater_Key_Node;
961 ----------------------
962 -- Is_Less_Key_Node --
963 ----------------------
965 function Is_Less_Key_Node
967 Right : Node_Access) return Boolean
970 return Left < Key (Right.Element.all);
971 end Is_Less_Key_Node;
977 function Key (Position : Cursor) return Key_Type is
979 if Position.Node = null then
980 raise Constraint_Error with
981 "Position cursor equals No_Element";
984 if Position.Node.Element = null then
985 raise Program_Error with
986 "Position cursor is bad";
989 pragma Assert (Vet (Position.Container.Tree, Position.Node),
990 "bad cursor in Key");
992 return Key (Position.Node.Element.all);
1000 (Container : in out Set;
1002 New_Item : Element_Type)
1004 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
1008 raise Constraint_Error with
1009 "attempt to replace key not in set";
1012 Replace_Element (Container.Tree, Node, New_Item);
1020 (Stream : not null access Root_Stream_Type'Class;
1021 Item : out Reference_Type)
1024 raise Program_Error with "attempt to stream reference";
1027 ------------------------------
1028 -- Reference_Preserving_Key --
1029 ------------------------------
1031 function Reference_Preserving_Key
1032 (Container : aliased in out Set;
1033 Position : Cursor) return Reference_Type
1036 if Position.Container = null then
1037 raise Constraint_Error with "Position cursor has no element";
1040 if Position.Container /= Container'Unrestricted_Access then
1041 raise Program_Error with
1042 "Position cursor designates wrong container";
1045 if Position.Node.Element = null then
1046 raise Program_Error with "Node has no element";
1050 (Vet (Container.Tree, Position.Node),
1051 "bad cursor in function Reference_Preserving_Key");
1054 Tree : Tree_Type renames Container.Tree;
1055 B : Natural renames Tree.Busy;
1056 L : Natural renames Tree.Lock;
1058 return R : constant Reference_Type :=
1059 (Element => Position.Node.Element.all'Unchecked_Access,
1062 Container => Container'Access,
1064 Old_Key => new Key_Type'(Key (Position))))
1070 end Reference_Preserving_Key;
1072 function Reference_Preserving_Key
1073 (Container : aliased in out Set;
1074 Key : Key_Type) return Reference_Type
1076 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
1080 raise Constraint_Error with "Key not in set";
1083 if Node.Element = null then
1084 raise Program_Error with "Node has no element";
1088 Tree : Tree_Type renames Container.Tree;
1089 B : Natural renames Tree.Busy;
1090 L : Natural renames Tree.Lock;
1092 return R : constant Reference_Type :=
1093 (Element => Node.Element.all'Unchecked_Access,
1096 Container => Container'Access,
1097 Pos => Find (Container, Key),
1098 Old_Key => new Key_Type'(Key)))
1104 end Reference_Preserving_Key;
1106 -----------------------------------
1107 -- Update_Element_Preserving_Key --
1108 -----------------------------------
1110 procedure Update_Element_Preserving_Key
1111 (Container : in out Set;
1113 Process : not null access
1114 procedure (Element : in out Element_Type))
1116 Tree : Tree_Type renames Container.Tree;
1119 if Position.Node = null then
1120 raise Constraint_Error with "Position cursor equals No_Element";
1123 if Position.Node.Element = null then
1124 raise Program_Error with "Position cursor is bad";
1127 if Position.Container /= Container'Unrestricted_Access then
1128 raise Program_Error with "Position cursor designates wrong set";
1131 pragma Assert (Vet (Container.Tree, Position.Node),
1132 "bad cursor in Update_Element_Preserving_Key");
1135 E : Element_Type renames Position.Node.Element.all;
1136 K : constant Key_Type := Key (E);
1138 B : Natural renames Tree.Busy;
1139 L : Natural renames Tree.Lock;
1149 Eq := Equivalent_Keys (K, Key (E));
1166 X : Node_Access := Position.Node;
1168 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
1172 raise Program_Error with "key was modified";
1173 end Update_Element_Preserving_Key;
1180 (Stream : not null access Root_Stream_Type'Class;
1181 Item : Reference_Type)
1184 raise Program_Error with "attempt to stream reference";
1193 function Has_Element (Position : Cursor) return Boolean is
1195 return Position /= No_Element;
1202 procedure Include (Container : in out Set; New_Item : Element_Type) is
1209 Insert (Container, New_Item, Position, Inserted);
1211 if not Inserted then
1212 if Container.Tree.Lock > 0 then
1213 raise Program_Error with
1214 "attempt to tamper with elements (set is locked)";
1218 -- The element allocator may need an accessibility check in the
1219 -- case the actual type is class-wide or has access discriminants
1220 -- (see RM 4.8(10.1) and AI12-0035).
1222 pragma Unsuppress (Accessibility_Check);
1225 X := Position.Node.Element;
1226 Position.Node.Element := new Element_Type'(New_Item);
1237 (Container : in out Set;
1238 New_Item : Element_Type;
1239 Position : out Cursor;
1240 Inserted : out Boolean)
1249 Position.Container := Container'Unrestricted_Access;
1252 procedure Insert (Container : in out Set; New_Item : Element_Type) is
1254 pragma Unreferenced (Position);
1259 Insert (Container, New_Item, Position, Inserted);
1261 if not Inserted then
1262 raise Constraint_Error with
1263 "attempt to insert element already in set";
1267 ----------------------
1268 -- Insert_Sans_Hint --
1269 ----------------------
1271 procedure Insert_Sans_Hint
1272 (Tree : in out Tree_Type;
1273 New_Item : Element_Type;
1274 Node : out Node_Access;
1275 Inserted : out Boolean)
1277 function New_Node return Node_Access;
1278 pragma Inline (New_Node);
1280 procedure Insert_Post is
1281 new Element_Keys.Generic_Insert_Post (New_Node);
1283 procedure Conditional_Insert_Sans_Hint is
1284 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1290 function New_Node return Node_Access is
1291 -- The element allocator may need an accessibility check in the case
1292 -- the actual type is class-wide or has access discriminants (see
1293 -- RM 4.8(10.1) and AI12-0035).
1295 pragma Unsuppress (Accessibility_Check);
1297 Element : Element_Access := new Element_Type'(New_Item);
1300 return new Node_Type'(Parent => null,
1303 Color => Red_Black_Trees.Red,
1304 Element => Element);
1308 Free_Element (Element);
1312 -- Start of processing for Insert_Sans_Hint
1315 Conditional_Insert_Sans_Hint
1320 end Insert_Sans_Hint;
1322 ----------------------
1323 -- Insert_With_Hint --
1324 ----------------------
1326 procedure Insert_With_Hint
1327 (Dst_Tree : in out Tree_Type;
1328 Dst_Hint : Node_Access;
1329 Src_Node : Node_Access;
1330 Dst_Node : out Node_Access)
1333 pragma Unreferenced (Success);
1335 function New_Node return Node_Access;
1337 procedure Insert_Post is
1338 new Element_Keys.Generic_Insert_Post (New_Node);
1340 procedure Insert_Sans_Hint is
1341 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1343 procedure Insert_With_Hint is
1344 new Element_Keys.Generic_Conditional_Insert_With_Hint
1352 function New_Node return Node_Access is
1353 Element : Element_Access := new Element_Type'(Src_Node.Element.all);
1358 Node := new Node_Type;
1361 Free_Element (Element);
1365 Node.Element := Element;
1369 -- Start of processing for Insert_With_Hint
1375 Src_Node.Element.all,
1378 end Insert_With_Hint;
1384 procedure Intersection (Target : in out Set; Source : Set) is
1386 Set_Ops.Intersection (Target.Tree, Source.Tree);
1389 function Intersection (Left, Right : Set) return Set is
1390 Tree : constant Tree_Type :=
1391 Set_Ops.Intersection (Left.Tree, Right.Tree);
1393 return Set'(Controlled with Tree);
1400 function Is_Empty (Container : Set) return Boolean is
1402 return Container.Tree.Length = 0;
1405 -----------------------------
1406 -- Is_Greater_Element_Node --
1407 -----------------------------
1409 function Is_Greater_Element_Node
1410 (Left : Element_Type;
1411 Right : Node_Access) return Boolean
1414 -- e > node same as node < e
1416 return Right.Element.all < Left;
1417 end Is_Greater_Element_Node;
1419 --------------------------
1420 -- Is_Less_Element_Node --
1421 --------------------------
1423 function Is_Less_Element_Node
1424 (Left : Element_Type;
1425 Right : Node_Access) return Boolean
1428 return Left < Right.Element.all;
1429 end Is_Less_Element_Node;
1431 -----------------------
1432 -- Is_Less_Node_Node --
1433 -----------------------
1435 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1437 return L.Element.all < R.Element.all;
1438 end Is_Less_Node_Node;
1444 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1446 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1455 Process : not null access procedure (Position : Cursor))
1457 procedure Process_Node (Node : Node_Access);
1458 pragma Inline (Process_Node);
1460 procedure Local_Iterate is
1461 new Tree_Operations.Generic_Iteration (Process_Node);
1467 procedure Process_Node (Node : Node_Access) is
1469 Process (Cursor'(Container'Unrestricted_Access, Node));
1472 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1473 B : Natural renames T.Busy;
1475 -- Start of processing for Iterate
1493 return Set_Iterator_Interfaces.Reversible_Iterator'class
1495 B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1498 -- The value of the Node component influences the behavior of the First
1499 -- and Last selector functions of the iterator object. When the Node
1500 -- component is null (as is the case here), this means the iterator
1501 -- object was constructed without a start expression. This is a complete
1502 -- iterator, meaning that the iteration starts from the (logical)
1503 -- beginning of the sequence of items.
1505 -- Note: For a forward iterator, Container.First is the beginning, and
1506 -- for a reverse iterator, Container.Last is the beginning.
1508 return It : constant Iterator :=
1509 Iterator'(Limited_Controlled with
1510 Container => Container'Unrestricted_Access,
1520 return Set_Iterator_Interfaces.Reversible_Iterator'class
1522 B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1525 -- It was formerly the case that when Start = No_Element, the partial
1526 -- iterator was defined to behave the same as for a complete iterator,
1527 -- and iterate over the entire sequence of items. However, those
1528 -- semantics were unintuitive and arguably error-prone (it is too easy
1529 -- to accidentally create an endless loop), and so they were changed,
1530 -- per the ARG meeting in Denver on 2011/11. However, there was no
1531 -- consensus about what positive meaning this corner case should have,
1532 -- and so it was decided to simply raise an exception. This does imply,
1533 -- however, that it is not possible to use a partial iterator to specify
1534 -- an empty sequence of items.
1536 if Start = No_Element then
1537 raise Constraint_Error with
1538 "Start position for iterator equals No_Element";
1541 if Start.Container /= Container'Unrestricted_Access then
1542 raise Program_Error with
1543 "Start cursor of Iterate designates wrong set";
1546 pragma Assert (Vet (Container.Tree, Start.Node),
1547 "Start cursor of Iterate is bad");
1549 -- The value of the Node component influences the behavior of the First
1550 -- and Last selector functions of the iterator object. When the Node
1551 -- component is non-null (as is the case here), it means that this is a
1552 -- partial iteration, over a subset of the complete sequence of
1553 -- items. The iterator object was constructed with a start expression,
1554 -- indicating the position from which the iteration begins. Note that
1555 -- the start position has the same value irrespective of whether this is
1556 -- a forward or reverse iteration.
1558 return It : constant Iterator :=
1559 (Limited_Controlled with
1560 Container => Container'Unrestricted_Access,
1571 function Last (Container : Set) return Cursor is
1574 (if Container.Tree.Last = null then No_Element
1575 else Cursor'(Container'Unrestricted_Access, Container.Tree.Last));
1578 function Last (Object : Iterator) return Cursor is
1580 -- The value of the iterator object's Node component influences the
1581 -- behavior of the Last (and First) selector function.
1583 -- When the Node component is null, this means the iterator object was
1584 -- constructed without a start expression, in which case the (reverse)
1585 -- iteration starts from the (logical) beginning of the entire sequence
1586 -- (corresponding to Container.Last, for a reverse iterator).
1588 -- Otherwise, this is iteration over a partial sequence of items. When
1589 -- the Node component is non-null, the iterator object was constructed
1590 -- with a start expression, that specifies the position from which the
1591 -- (reverse) partial iteration begins.
1593 if Object.Node = null then
1594 return Object.Container.Last;
1596 return Cursor'(Object.Container, Object.Node);
1604 function Last_Element (Container : Set) return Element_Type is
1606 if Container.Tree.Last = null then
1607 raise Constraint_Error with "set is empty";
1609 return Container.Tree.Last.Element.all;
1617 function Left (Node : Node_Access) return Node_Access is
1626 function Length (Container : Set) return Count_Type is
1628 return Container.Tree.Length;
1635 procedure Move is new Tree_Operations.Generic_Move (Clear);
1637 procedure Move (Target : in out Set; Source : in out Set) is
1639 Move (Target => Target.Tree, Source => Source.Tree);
1646 procedure Next (Position : in out Cursor) is
1648 Position := Next (Position);
1651 function Next (Position : Cursor) return Cursor is
1653 if Position = No_Element then
1657 if Position.Node.Element = null then
1658 raise Program_Error with "Position cursor is bad";
1661 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1662 "bad cursor in Next");
1665 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
1667 return (if Node = null then No_Element
1668 else Cursor'(Position.Container, Node));
1674 Position : Cursor) return Cursor
1677 if Position.Container = null then
1681 if Position.Container /= Object.Container then
1682 raise Program_Error with
1683 "Position cursor of Next designates wrong set";
1686 return Next (Position);
1693 function Overlap (Left, Right : Set) return Boolean is
1695 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1702 function Parent (Node : Node_Access) return Node_Access is
1711 procedure Previous (Position : in out Cursor) is
1713 Position := Previous (Position);
1716 function Previous (Position : Cursor) return Cursor is
1718 if Position = No_Element then
1722 if Position.Node.Element = null then
1723 raise Program_Error with "Position cursor is bad";
1726 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1727 "bad cursor in Previous");
1730 Node : constant Node_Access :=
1731 Tree_Operations.Previous (Position.Node);
1733 return (if Node = null then No_Element
1734 else Cursor'(Position.Container, Node));
1740 Position : Cursor) return Cursor
1743 if Position.Container = null then
1747 if Position.Container /= Object.Container then
1748 raise Program_Error with
1749 "Position cursor of Previous designates wrong set";
1752 return Previous (Position);
1759 procedure Query_Element
1761 Process : not null access procedure (Element : Element_Type))
1764 if Position.Node = null then
1765 raise Constraint_Error with "Position cursor equals No_Element";
1768 if Position.Node.Element = null then
1769 raise Program_Error with "Position cursor is bad";
1772 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1773 "bad cursor in Query_Element");
1776 T : Tree_Type renames Position.Container.Tree;
1778 B : Natural renames T.Busy;
1779 L : Natural renames T.Lock;
1786 Process (Position.Node.Element.all);
1804 (Stream : not null access Root_Stream_Type'Class;
1805 Container : out Set)
1808 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1809 pragma Inline (Read_Node);
1812 new Tree_Operations.Generic_Read (Clear, Read_Node);
1819 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1821 Node : Node_Access := new Node_Type;
1824 Node.Element := new Element_Type'(Element_Type'Input (Stream));
1829 Free (Node); -- Note that Free deallocates elem too
1833 -- Start of processing for Read
1836 Read (Stream, Container.Tree);
1840 (Stream : not null access Root_Stream_Type'Class;
1844 raise Program_Error with "attempt to stream set cursor";
1848 (Stream : not null access Root_Stream_Type'Class;
1849 Item : out Constant_Reference_Type)
1852 raise Program_Error with "attempt to stream reference";
1859 procedure Replace (Container : in out Set; New_Item : Element_Type) is
1860 Node : constant Node_Access :=
1861 Element_Keys.Find (Container.Tree, New_Item);
1864 pragma Warnings (Off, X);
1868 raise Constraint_Error with "attempt to replace element not in set";
1871 if Container.Tree.Lock > 0 then
1872 raise Program_Error with
1873 "attempt to tamper with elements (set is locked)";
1877 -- The element allocator may need an accessibility check in the case
1878 -- the actual type is class-wide or has access discriminants (see
1879 -- RM 4.8(10.1) and AI12-0035).
1881 pragma Unsuppress (Accessibility_Check);
1885 Node.Element := new Element_Type'(New_Item);
1890 ---------------------
1891 -- Replace_Element --
1892 ---------------------
1894 procedure Replace_Element
1895 (Tree : in out Tree_Type;
1897 Item : Element_Type)
1899 pragma Assert (Node /= null);
1900 pragma Assert (Node.Element /= null);
1902 function New_Node return Node_Access;
1903 pragma Inline (New_Node);
1905 procedure Local_Insert_Post is
1906 new Element_Keys.Generic_Insert_Post (New_Node);
1908 procedure Local_Insert_Sans_Hint is
1909 new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
1911 procedure Local_Insert_With_Hint is
1912 new Element_Keys.Generic_Conditional_Insert_With_Hint
1914 Local_Insert_Sans_Hint);
1920 function New_Node return Node_Access is
1922 -- The element allocator may need an accessibility check in the case
1923 -- the actual type is class-wide or has access discriminants (see
1924 -- RM 4.8(10.1) and AI12-0035).
1926 pragma Unsuppress (Accessibility_Check);
1929 Node.Element := new Element_Type'(Item); -- OK if fails
1931 Node.Parent := null;
1938 Result : Node_Access;
1942 X : Element_Access := Node.Element;
1944 -- Per AI05-0022, the container implementation is required to detect
1945 -- element tampering by a generic actual subprogram.
1947 B : Natural renames Tree.Busy;
1948 L : Natural renames Tree.Lock;
1950 -- Start of processing for Replace_Element
1953 -- Replace_Element assigns value Item to the element designated by Node,
1954 -- per certain semantic constraints, described as follows.
1956 -- If Item is equivalent to the element, then element is replaced and
1957 -- there's nothing else to do. This is the easy case.
1959 -- If Item is not equivalent, then the node will (possibly) have to move
1960 -- to some other place in the tree. This is slighly more complicated,
1961 -- because we must ensure that Item is not equivalent to some other
1962 -- element in the tree (in which case, the replacement is not allowed).
1964 -- Determine whether Item is equivalent to element on the specified
1971 Compare := (if Item < Node.Element.all then False
1972 elsif Node.Element.all < Item then False
1987 -- Item is equivalent to the node's element, so we will not have to
1990 if Tree.Lock > 0 then
1991 raise Program_Error with
1992 "attempt to tamper with elements (set is locked)";
1996 -- The element allocator may need an accessibility check in the
1997 -- case the actual type is class-wide or has access discriminants
1998 -- (see RM 4.8(10.1) and AI12-0035).
2000 pragma Unsuppress (Accessibility_Check);
2003 Node.Element := new Element_Type'(Item);
2010 -- The replacement Item is not equivalent to the element on the
2011 -- specified node, which means that it will need to be re-inserted in a
2012 -- different position in the tree. We must now determine whether Item is
2013 -- equivalent to some other element in the tree (which would prohibit
2014 -- the assignment and hence the move).
2016 -- Ceiling returns the smallest element equivalent or greater than the
2017 -- specified Item; if there is no such element, then it returns null.
2019 Hint := Element_Keys.Ceiling (Tree, Item);
2021 if Hint /= null then
2026 Compare := Item < Hint.Element.all;
2039 -- Item >= Hint.Element
2043 -- Ceiling returns an element that is equivalent or greater
2044 -- than Item. If Item is "not less than" the element, then
2045 -- by elimination we know that Item is equivalent to the element.
2047 -- But this means that it is not possible to assign the value of
2048 -- Item to the specified element (on Node), because a different
2049 -- element (on Hint) equivalent to Item already exsits. (Were we
2050 -- to change Node's element value, we would have to move Node, but
2051 -- we would be unable to move the Node, because its new position
2052 -- in the tree is already occupied by an equivalent element.)
2054 raise Program_Error with "attempt to replace existing element";
2057 -- Item is not equivalent to any other element in the tree, so it is
2058 -- safe to assign the value of Item to Node.Element. This means that
2059 -- the node will have to move to a different position in the tree
2060 -- (because its element will have a different value).
2062 -- The nearest (greater) neighbor of Item is Hint. This will be the
2063 -- insertion position of Node (because its element will have Item as
2066 -- If Node equals Hint, the relative position of Node does not
2067 -- change. This allows us to perform an optimization: we need not
2068 -- remove Node from the tree and then reinsert it with its new value,
2069 -- because it would only be placed in the exact same position.
2072 if Tree.Lock > 0 then
2073 raise Program_Error with
2074 "attempt to tamper with elements (set is locked)";
2078 -- The element allocator may need an accessibility check in the
2079 -- case actual type is class-wide or has access discriminants
2080 -- (see RM 4.8(10.1) and AI12-0035).
2082 pragma Unsuppress (Accessibility_Check);
2085 Node.Element := new Element_Type'(Item);
2093 -- If we get here, it is because Item was greater than all elements in
2094 -- the tree (Hint = null), or because Item was less than some element at
2095 -- a different place in the tree (Item < Hint.Element.all). In either
2096 -- case, we remove Node from the tree (without actually deallocating
2097 -- it), and then insert Item into the tree, onto the same Node (so no
2098 -- new node is actually allocated).
2100 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
2102 Local_Insert_With_Hint
2107 Inserted => Inserted);
2109 pragma Assert (Inserted);
2110 pragma Assert (Result = Node);
2113 end Replace_Element;
2115 procedure Replace_Element
2116 (Container : in out Set;
2118 New_Item : Element_Type)
2121 if Position.Node = null then
2122 raise Constraint_Error with "Position cursor equals No_Element";
2125 if Position.Node.Element = null then
2126 raise Program_Error with "Position cursor is bad";
2129 if Position.Container /= Container'Unrestricted_Access then
2130 raise Program_Error with "Position cursor designates wrong set";
2133 pragma Assert (Vet (Container.Tree, Position.Node),
2134 "bad cursor in Replace_Element");
2136 Replace_Element (Container.Tree, Position.Node, New_Item);
2137 end Replace_Element;
2139 ---------------------
2140 -- Reverse_Iterate --
2141 ---------------------
2143 procedure Reverse_Iterate
2145 Process : not null access procedure (Position : Cursor))
2147 procedure Process_Node (Node : Node_Access);
2148 pragma Inline (Process_Node);
2150 procedure Local_Reverse_Iterate is
2151 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
2157 procedure Process_Node (Node : Node_Access) is
2159 Process (Cursor'(Container'Unrestricted_Access, Node));
2162 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
2163 B : Natural renames T.Busy;
2165 -- Start of processing for Reverse_Iterate
2171 Local_Reverse_Iterate (T);
2179 end Reverse_Iterate;
2185 function Right (Node : Node_Access) return Node_Access is
2194 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
2196 Node.Color := Color;
2203 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
2212 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
2214 Node.Parent := Parent;
2221 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
2223 Node.Right := Right;
2226 --------------------------
2227 -- Symmetric_Difference --
2228 --------------------------
2230 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
2232 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
2233 end Symmetric_Difference;
2235 function Symmetric_Difference (Left, Right : Set) return Set is
2236 Tree : constant Tree_Type :=
2237 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
2239 return Set'(Controlled with Tree);
2240 end Symmetric_Difference;
2246 function To_Set (New_Item : Element_Type) return Set is
2250 pragma Unreferenced (Node, Inserted);
2252 Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
2253 return Set'(Controlled with Tree);
2260 procedure Union (Target : in out Set; Source : Set) is
2262 Set_Ops.Union (Target.Tree, Source.Tree);
2265 function Union (Left, Right : Set) return Set is
2266 Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
2268 return Set'(Controlled with Tree);
2276 (Stream : not null access Root_Stream_Type'Class;
2279 procedure Write_Node
2280 (Stream : not null access Root_Stream_Type'Class;
2281 Node : Node_Access);
2282 pragma Inline (Write_Node);
2285 new Tree_Operations.Generic_Write (Write_Node);
2291 procedure Write_Node
2292 (Stream : not null access Root_Stream_Type'Class;
2296 Element_Type'Output (Stream, Node.Element.all);
2299 -- Start of processing for Write
2302 Write (Stream, Container.Tree);
2306 (Stream : not null access Root_Stream_Type'Class;
2310 raise Program_Error with "attempt to stream set cursor";
2314 (Stream : not null access Root_Stream_Type'Class;
2315 Item : Constant_Reference_Type)
2318 raise Program_Error with "attempt to stream reference";
2321 end Ada.Containers.Indefinite_Ordered_Sets;