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-2024, 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
;
42 with System
.Put_Images
;
44 package body Ada
.Containers
.Ordered_Multisets
with
48 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
49 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
50 -- See comment in Ada.Containers.Helpers
52 -----------------------------
53 -- Node Access Subprograms --
54 -----------------------------
56 -- These subprograms provide a functional interface to access fields
57 -- of a node, and a procedural interface for modifying these values.
59 function Color
(Node
: Node_Access
) return Color_Type
;
60 pragma Inline
(Color
);
62 function Left
(Node
: Node_Access
) return Node_Access
;
65 function Parent
(Node
: Node_Access
) return Node_Access
;
66 pragma Inline
(Parent
);
68 function Right
(Node
: Node_Access
) return Node_Access
;
69 pragma Inline
(Right
);
71 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
72 pragma Inline
(Set_Parent
);
74 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
75 pragma Inline
(Set_Left
);
77 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
78 pragma Inline
(Set_Right
);
80 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
81 pragma Inline
(Set_Color
);
83 -----------------------
84 -- Local Subprograms --
85 -----------------------
87 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
88 pragma Inline
(Copy_Node
);
90 procedure Free
(X
: in out Node_Access
);
92 procedure Insert_Sans_Hint
93 (Tree
: in out Tree_Type
;
94 New_Item
: Element_Type
;
95 Node
: out Node_Access
);
97 procedure Insert_With_Hint
98 (Dst_Tree
: in out Tree_Type
;
99 Dst_Hint
: Node_Access
;
100 Src_Node
: Node_Access
;
101 Dst_Node
: out Node_Access
);
103 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean;
104 pragma Inline
(Is_Equal_Node_Node
);
106 function Is_Greater_Element_Node
107 (Left
: Element_Type
;
108 Right
: Node_Access
) return Boolean;
109 pragma Inline
(Is_Greater_Element_Node
);
111 function Is_Less_Element_Node
112 (Left
: Element_Type
;
113 Right
: Node_Access
) return Boolean;
114 pragma Inline
(Is_Less_Element_Node
);
116 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean;
117 pragma Inline
(Is_Less_Node_Node
);
119 procedure Replace_Element
120 (Tree
: in out Tree_Type
;
122 Item
: Element_Type
);
124 --------------------------
125 -- Local Instantiations --
126 --------------------------
128 package Tree_Operations
is
129 new Red_Black_Trees
.Generic_Operations
(Tree_Types
);
131 procedure Delete_Tree
is
132 new Tree_Operations
.Generic_Delete_Tree
(Free
);
134 function Copy_Tree
is
135 new Tree_Operations
.Generic_Copy_Tree
(Copy_Node
, Delete_Tree
);
140 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
142 package Element_Keys
is
143 new Red_Black_Trees
.Generic_Keys
144 (Tree_Operations
=> Tree_Operations
,
145 Key_Type
=> Element_Type
,
146 Is_Less_Key_Node
=> Is_Less_Element_Node
,
147 Is_Greater_Key_Node
=> Is_Greater_Element_Node
);
150 new Generic_Set_Operations
151 (Tree_Operations
=> Tree_Operations
,
152 Insert_With_Hint
=> Insert_With_Hint
,
153 Copy_Tree
=> Copy_Tree
,
154 Delete_Tree
=> Delete_Tree
,
155 Is_Less
=> Is_Less_Node_Node
,
162 function "<" (Left
, Right
: Cursor
) return Boolean is
164 if Left
.Node
= null then
165 raise Constraint_Error
with "Left cursor equals No_Element";
168 if Right
.Node
= null then
169 raise Constraint_Error
with "Right cursor equals No_Element";
172 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
173 "bad Left cursor in ""<""");
175 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
176 "bad Right cursor in ""<""");
178 return Left
.Node
.Element
< Right
.Node
.Element
;
181 function "<" (Left
: Cursor
; Right
: Element_Type
)
184 if Left
.Node
= null then
185 raise Constraint_Error
with "Left cursor equals No_Element";
188 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
189 "bad Left cursor in ""<""");
191 return Left
.Node
.Element
< Right
;
194 function "<" (Left
: Element_Type
; Right
: Cursor
)
197 if Right
.Node
= null then
198 raise Constraint_Error
with "Right cursor equals No_Element";
201 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
202 "bad Right cursor in ""<""");
204 return Left
< Right
.Node
.Element
;
211 function "=" (Left
, Right
: Set
) return Boolean is
213 return Is_Equal
(Left
.Tree
, Right
.Tree
);
220 function ">" (Left
, Right
: Cursor
) return Boolean is
222 if Left
.Node
= null then
223 raise Constraint_Error
with "Left cursor equals No_Element";
226 if Right
.Node
= null then
227 raise Constraint_Error
with "Right cursor equals No_Element";
230 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
231 "bad Left cursor in "">""");
233 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
234 "bad Right cursor in "">""");
236 -- L > R same as R < L
238 return Right
.Node
.Element
< Left
.Node
.Element
;
241 function ">" (Left
: Cursor
; Right
: Element_Type
)
244 if Left
.Node
= null then
245 raise Constraint_Error
with "Left cursor equals No_Element";
248 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
249 "bad Left cursor in "">""");
251 return Right
< Left
.Node
.Element
;
254 function ">" (Left
: Element_Type
; Right
: Cursor
)
257 if Right
.Node
= null then
258 raise Constraint_Error
with "Right cursor equals No_Element";
261 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
262 "bad Right cursor in "">""");
264 return Right
.Node
.Element
< Left
;
271 procedure Adjust
is new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
273 procedure Adjust
(Container
: in out Set
) is
275 Adjust
(Container
.Tree
);
282 procedure Assign
(Target
: in out Set
; Source
: Set
) is
284 if Target
'Address = Source
'Address then
289 Target
.Union
(Source
);
296 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
is
297 Node
: constant Node_Access
:=
298 Element_Keys
.Ceiling
(Container
.Tree
, Item
);
305 return Cursor
'(Container'Unrestricted_Access, Node);
313 new Tree_Operations.Generic_Clear (Delete_Tree);
315 procedure Clear (Container : in out Set) is
317 Clear (Container.Tree);
324 function Color (Node : Node_Access) return Color_Type is
329 ------------------------
330 -- Constant_Reference --
331 ------------------------
333 function Constant_Reference
334 (Container : aliased Set;
335 Position : Cursor) return Constant_Reference_Type
338 if Position.Container = null then
339 raise Constraint_Error with "Position cursor has no element";
342 if Position.Container /= Container'Unrestricted_Access then
343 raise Program_Error with
344 "Position cursor designates wrong container";
347 pragma Assert (Vet (Position.Container.Tree, Position.Node),
348 "bad cursor in Constant_Reference");
350 -- Note: in predefined container units, the creation of a reference
351 -- increments the busy bit of the container, and its finalization
352 -- decrements it. In the absence of control machinery, this tampering
353 -- protection is missing.
356 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
357 pragma Unreferenced (T);
359 return R : constant Constant_Reference_Type :=
360 (Element => Position.Node.Element'Unrestricted_Access,
361 Control => (Container => Container'Unrestricted_Access))
366 end Constant_Reference;
372 function Contains (Container : Set; Item : Element_Type) return Boolean is
374 return Find (Container, Item) /= No_Element;
381 function Copy (Source : Set) return Set is
383 return Target : Set do
384 Target.Assign (Source);
392 function Copy_Node (Source : Node_Access) return Node_Access is
393 Target : constant Node_Access :=
394 new Node_Type'(Parent
=> null,
397 Color
=> Source
.Color
,
398 Element
=> Source
.Element
);
407 procedure Delete
(Container
: in out Set
; Item
: Element_Type
) is
408 Tree
: Tree_Type
renames Container
.Tree
;
409 Node
: Node_Access
:= Element_Keys
.Ceiling
(Tree
, Item
);
410 Done
: constant Node_Access
:= Element_Keys
.Upper_Bound
(Tree
, Item
);
415 raise Constraint_Error
with
416 "attempt to delete element not in set";
421 Node
:= Tree_Operations
.Next
(Node
);
422 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
425 exit when Node
= Done
;
429 procedure Delete
(Container
: in out Set
; Position
: in out Cursor
) is
431 if Position
.Node
= null then
432 raise Constraint_Error
with "Position cursor equals No_Element";
435 if Position
.Container
/= Container
'Unrestricted_Access then
436 raise Program_Error
with "Position cursor designates wrong set";
439 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
440 "bad cursor in Delete");
442 Delete_Node_Sans_Free
(Container
.Tree
, Position
.Node
);
443 Free
(Position
.Node
);
445 Position
.Container
:= null;
452 procedure Delete_First
(Container
: in out Set
) is
453 Tree
: Tree_Type
renames Container
.Tree
;
454 X
: Node_Access
:= Tree
.First
;
461 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
469 procedure Delete_Last
(Container
: in out Set
) is
470 Tree
: Tree_Type
renames Container
.Tree
;
471 X
: Node_Access
:= Tree
.Last
;
478 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
486 procedure Difference
(Target
: in out Set
; Source
: Set
) is
488 Set_Ops
.Difference
(Target
.Tree
, Source
.Tree
);
491 function Difference
(Left
, Right
: Set
) return Set
is
492 Tree
: constant Tree_Type
:=
493 Set_Ops
.Difference
(Left
.Tree
, Right
.Tree
);
495 return Set
'(Controlled with Tree);
502 function Element (Position : Cursor) return Element_Type is
504 if Position.Node = null then
505 raise Constraint_Error with "Position cursor equals No_Element";
509 and then (Left (Position.Node) = Position.Node
511 Right (Position.Node) = Position.Node)
513 raise Program_Error with "dangling cursor";
516 pragma Assert (Vet (Position.Container.Tree, Position.Node),
517 "bad cursor in Element");
519 return Position.Node.Element;
522 -------------------------
523 -- Equivalent_Elements --
524 -------------------------
526 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
535 end Equivalent_Elements;
537 ---------------------
538 -- Equivalent_Sets --
539 ---------------------
541 function Equivalent_Sets (Left, Right : Set) return Boolean is
543 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
544 pragma Inline (Is_Equivalent_Node_Node);
546 function Is_Equivalent is
547 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
549 -----------------------------
550 -- Is_Equivalent_Node_Node --
551 -----------------------------
553 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
555 if L.Element < R.Element then
557 elsif R.Element < L.Element then
562 end Is_Equivalent_Node_Node;
564 -- Start of processing for Equivalent_Sets
567 return Is_Equivalent (Left.Tree, Right.Tree);
574 procedure Exclude (Container : in out Set; Item : Element_Type) is
575 Tree : Tree_Type renames Container.Tree;
576 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
577 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
580 while Node /= Done loop
582 Node := Tree_Operations.Next (Node);
583 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
592 procedure Finalize (Object : in out Iterator) is
594 Unbusy (Object.Container.Tree.TC);
601 function Find (Container : Set; Item : Element_Type) return Cursor is
602 Node : constant Node_Access :=
603 Element_Keys.Find (Container.Tree, Item);
610 return Cursor'(Container
'Unrestricted_Access, Node
);
617 function First
(Container
: Set
) return Cursor
is
619 if Container
.Tree
.First
= null then
623 return Cursor
'(Container'Unrestricted_Access, Container.Tree.First);
626 function First (Object : Iterator) return Cursor is
628 -- The value of the iterator object's Node component influences the
629 -- behavior of the First (and Last) selector function.
631 -- When the Node component is null, this means the iterator object was
632 -- constructed without a start expression, in which case the (forward)
633 -- iteration starts from the (logical) beginning of the entire sequence
634 -- of items (corresponding to Container.First, for a forward iterator).
636 -- Otherwise, this is iteration over a partial sequence of items. When
637 -- the Node component is non-null, the iterator object was constructed
638 -- with a start expression, that specifies the position from which the
639 -- (forward) partial iteration begins.
641 if Object.Node = null then
642 return Object.Container.First;
644 return Cursor'(Object
.Container
, Object
.Node
);
652 function First_Element
(Container
: Set
) return Element_Type
is
654 if Container
.Tree
.First
= null then
655 raise Constraint_Error
with "set is empty";
658 return Container
.Tree
.First
.Element
;
665 function Floor
(Container
: Set
; Item
: Element_Type
) return Cursor
is
666 Node
: constant Node_Access
:=
667 Element_Keys
.Floor
(Container
.Tree
, Item
);
674 return Cursor
'(Container'Unrestricted_Access, Node);
681 procedure Free (X : in out Node_Access) is
682 procedure Deallocate is
683 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
699 package body Generic_Keys is
701 -----------------------
702 -- Local Subprograms --
703 -----------------------
705 function Is_Greater_Key_Node
707 Right : Node_Access) return Boolean;
708 pragma Inline (Is_Greater_Key_Node);
710 function Is_Less_Key_Node
712 Right : Node_Access) return Boolean;
713 pragma Inline (Is_Less_Key_Node);
715 --------------------------
716 -- Local_Instantiations --
717 --------------------------
720 new Red_Black_Trees.Generic_Keys
721 (Tree_Operations => Tree_Operations,
722 Key_Type => Key_Type,
723 Is_Less_Key_Node => Is_Less_Key_Node,
724 Is_Greater_Key_Node => Is_Greater_Key_Node);
730 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
731 Node : constant Node_Access :=
732 Key_Keys.Ceiling (Container.Tree, Key);
739 return Cursor'(Container
'Unrestricted_Access, Node
);
746 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean is
748 return Find
(Container
, Key
) /= No_Element
;
755 procedure Delete
(Container
: in out Set
; Key
: Key_Type
) is
756 Tree
: Tree_Type
renames Container
.Tree
;
757 Node
: Node_Access
:= Key_Keys
.Ceiling
(Tree
, Key
);
758 Done
: constant Node_Access
:= Key_Keys
.Upper_Bound
(Tree
, Key
);
763 raise Constraint_Error
with "attempt to delete key not in set";
768 Node
:= Tree_Operations
.Next
(Node
);
769 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
772 exit when Node
= Done
;
780 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
is
781 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
784 raise Constraint_Error
with "key not in set";
790 ---------------------
791 -- Equivalent_Keys --
792 ---------------------
794 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
809 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
) is
810 Tree
: Tree_Type
renames Container
.Tree
;
811 Node
: Node_Access
:= Key_Keys
.Ceiling
(Tree
, Key
);
812 Done
: constant Node_Access
:= Key_Keys
.Upper_Bound
(Tree
, Key
);
816 while Node
/= Done
loop
818 Node
:= Tree_Operations
.Next
(Node
);
819 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
828 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
is
829 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
836 return Cursor
'(Container'Unrestricted_Access, Node);
843 function Floor (Container : Set; Key : Key_Type) return Cursor is
844 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
851 return Cursor'(Container
'Unrestricted_Access, Node
);
854 -------------------------
855 -- Is_Greater_Key_Node --
856 -------------------------
858 function Is_Greater_Key_Node
860 Right
: Node_Access
) return Boolean is
862 return Key
(Right
.Element
) < Left
;
863 end Is_Greater_Key_Node
;
865 ----------------------
866 -- Is_Less_Key_Node --
867 ----------------------
869 function Is_Less_Key_Node
871 Right
: Node_Access
) return Boolean is
873 return Left
< Key
(Right
.Element
);
874 end Is_Less_Key_Node
;
883 Process
: not null access procedure (Position
: Cursor
))
885 procedure Process_Node
(Node
: Node_Access
);
886 pragma Inline
(Process_Node
);
888 procedure Local_Iterate
is
889 new Key_Keys
.Generic_Iteration
(Process_Node
);
895 procedure Process_Node
(Node
: Node_Access
) is
897 Process
(Cursor
'(Container'Unrestricted_Access, Node));
900 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
901 Busy : With_Busy (T.TC'Unrestricted_Access);
903 -- Start of processing for Iterate
906 Local_Iterate (T, Key);
913 function Key (Position : Cursor) return Key_Type is
915 if Position.Node = null then
916 raise Constraint_Error with
917 "Position cursor equals No_Element";
920 pragma Assert (Vet (Position.Container.Tree, Position.Node),
921 "bad cursor in Key");
923 return Key (Position.Node.Element);
926 ---------------------
927 -- Reverse_Iterate --
928 ---------------------
930 procedure Reverse_Iterate
933 Process : not null access procedure (Position : Cursor))
935 procedure Process_Node (Node : Node_Access);
936 pragma Inline (Process_Node);
938 procedure Local_Reverse_Iterate is
939 new Key_Keys.Generic_Reverse_Iteration (Process_Node);
945 procedure Process_Node (Node : Node_Access) is
947 Process (Cursor'(Container
'Unrestricted_Access, Node
));
950 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
951 Busy
: With_Busy
(T
.TC
'Unrestricted_Access);
953 -- Start of processing for Reverse_Iterate
956 Local_Reverse_Iterate
(T
, Key
);
963 procedure Update_Element
964 (Container
: in out Set
;
966 Process
: not null access procedure (Element
: in out Element_Type
))
968 Tree
: Tree_Type
renames Container
.Tree
;
969 Node
: constant Node_Access
:= Position
.Node
;
973 raise Constraint_Error
with
974 "Position cursor equals No_Element";
977 if Position
.Container
/= Container
'Unrestricted_Access then
978 raise Program_Error
with
979 "Position cursor designates wrong set";
982 pragma Assert
(Vet
(Tree
, Node
),
983 "bad cursor in Update_Element");
986 E
: Element_Type
renames Node
.Element
;
987 K
: constant Key_Type
:= Key
(E
);
988 Lock
: With_Lock
(Tree
.TC
'Unrestricted_Access);
992 if Equivalent_Keys
(Left
=> K
, Right
=> Key
(E
)) then
997 -- Delete_Node checks busy-bit
999 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Node
);
1001 Insert_New_Item
: declare
1002 function New_Node
return Node_Access
;
1003 pragma Inline
(New_Node
);
1005 procedure Insert_Post
is
1006 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1008 procedure Unconditional_Insert
is
1009 new Element_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
1015 function New_Node
return Node_Access
is
1017 Node
.Color
:= Red_Black_Trees
.Red
;
1018 Node
.Parent
:= null;
1025 Result
: Node_Access
;
1027 -- Start of processing for Insert_New_Item
1030 Unconditional_Insert
1032 Key
=> Node
.Element
,
1035 pragma Assert
(Result
= Node
);
1036 end Insert_New_Item
;
1045 function Has_Element
(Position
: Cursor
) return Boolean is
1047 return Position
/= No_Element
;
1054 procedure Insert
(Container
: in out Set
; New_Item
: Element_Type
) is
1057 Insert
(Container
, New_Item
, Position
);
1061 (Container
: in out Set
;
1062 New_Item
: Element_Type
;
1063 Position
: out Cursor
)
1066 Insert_Sans_Hint
(Container
.Tree
, New_Item
, Position
.Node
);
1067 Position
.Container
:= Container
'Unrestricted_Access;
1070 ----------------------
1071 -- Insert_Sans_Hint --
1072 ----------------------
1074 procedure Insert_Sans_Hint
1075 (Tree
: in out Tree_Type
;
1076 New_Item
: Element_Type
;
1077 Node
: out Node_Access
)
1079 function New_Node
return Node_Access
;
1080 pragma Inline
(New_Node
);
1082 procedure Insert_Post
is
1083 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1085 procedure Unconditional_Insert
is
1086 new Element_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
1092 function New_Node
return Node_Access
is
1093 Node
: constant Node_Access
:=
1094 new Node_Type
'(Parent => null,
1097 Color => Red_Black_Trees.Red,
1098 Element => New_Item);
1103 -- Start of processing for Insert_Sans_Hint
1106 Unconditional_Insert (Tree, New_Item, Node);
1107 end Insert_Sans_Hint;
1109 ----------------------
1110 -- Insert_With_Hint --
1111 ----------------------
1113 procedure Insert_With_Hint
1114 (Dst_Tree : in out Tree_Type;
1115 Dst_Hint : Node_Access;
1116 Src_Node : Node_Access;
1117 Dst_Node : out Node_Access)
1119 function New_Node return Node_Access;
1120 pragma Inline (New_Node);
1122 procedure Insert_Post is
1123 new Element_Keys.Generic_Insert_Post (New_Node);
1125 procedure Insert_Sans_Hint is
1126 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1128 procedure Local_Insert_With_Hint is
1129 new Element_Keys.Generic_Unconditional_Insert_With_Hint
1137 function New_Node return Node_Access is
1138 Node : constant Node_Access :=
1139 new Node_Type'(Parent
=> null,
1143 Element
=> Src_Node
.Element
);
1148 -- Start of processing for Insert_With_Hint
1151 Local_Insert_With_Hint
1156 end Insert_With_Hint
;
1162 procedure Intersection
(Target
: in out Set
; Source
: Set
) is
1164 Set_Ops
.Intersection
(Target
.Tree
, Source
.Tree
);
1167 function Intersection
(Left
, Right
: Set
) return Set
is
1168 Tree
: constant Tree_Type
:=
1169 Set_Ops
.Intersection
(Left
.Tree
, Right
.Tree
);
1171 return Set
'(Controlled with Tree);
1178 function Is_Empty (Container : Set) return Boolean is
1180 return Container.Tree.Length = 0;
1183 ------------------------
1184 -- Is_Equal_Node_Node --
1185 ------------------------
1187 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1189 return L.Element = R.Element;
1190 end Is_Equal_Node_Node;
1192 -----------------------------
1193 -- Is_Greater_Element_Node --
1194 -----------------------------
1196 function Is_Greater_Element_Node
1197 (Left : Element_Type;
1198 Right : Node_Access) return Boolean
1201 -- e > node same as node < e
1203 return Right.Element < Left;
1204 end Is_Greater_Element_Node;
1206 --------------------------
1207 -- Is_Less_Element_Node --
1208 --------------------------
1210 function Is_Less_Element_Node
1211 (Left : Element_Type;
1212 Right : Node_Access) return Boolean
1215 return Left < Right.Element;
1216 end Is_Less_Element_Node;
1218 -----------------------
1219 -- Is_Less_Node_Node --
1220 -----------------------
1222 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1224 return L.Element < R.Element;
1225 end Is_Less_Node_Node;
1231 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1233 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1242 Process : not null access procedure (Position : Cursor))
1244 procedure Process_Node (Node : Node_Access);
1245 pragma Inline (Process_Node);
1247 procedure Local_Iterate is
1248 new Tree_Operations.Generic_Iteration (Process_Node);
1254 procedure Process_Node (Node : Node_Access) is
1256 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1259 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
1260 Busy
: With_Busy
(T
.TC
'Unrestricted_Access);
1262 -- Start of processing for Iterate
1270 Item
: Element_Type
;
1271 Process
: not null access procedure (Position
: Cursor
))
1273 procedure Process_Node
(Node
: Node_Access
);
1274 pragma Inline
(Process_Node
);
1276 procedure Local_Iterate
is
1277 new Element_Keys
.Generic_Iteration
(Process_Node
);
1283 procedure Process_Node
(Node
: Node_Access
) is
1285 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1288 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1289 Busy : With_Busy (T.TC'Unrestricted_Access);
1291 -- Start of processing for Iterate
1294 Local_Iterate (T, Item);
1297 function Iterate (Container : Set)
1298 return Set_Iterator_Interfaces.Reversible_Iterator'Class
1300 S : constant Set_Access := Container'Unrestricted_Access;
1302 -- The value of the Node component influences the behavior of the First
1303 -- and Last selector functions of the iterator object. When the Node
1304 -- component is null (as is the case here), this means the iterator
1305 -- object was constructed without a start expression. This is a complete
1306 -- iterator, meaning that the iteration starts from the (logical)
1307 -- beginning of the sequence of items.
1309 -- Note: For a forward iterator, Container.First is the beginning, and
1310 -- for a reverse iterator, Container.Last is the beginning.
1312 return It : constant Iterator := (Limited_Controlled with S, null) do
1317 function Iterate (Container : Set; Start : Cursor)
1318 return Set_Iterator_Interfaces.Reversible_Iterator'Class
1320 S : constant Set_Access := Container'Unrestricted_Access;
1322 -- It was formerly the case that when Start = No_Element, the partial
1323 -- iterator was defined to behave the same as for a complete iterator,
1324 -- and iterate over the entire sequence of items. However, those
1325 -- semantics were unintuitive and arguably error-prone (it is too easy
1326 -- to accidentally create an endless loop), and so they were changed,
1327 -- per the ARG meeting in Denver on 2011/11. However, there was no
1328 -- consensus about what positive meaning this corner case should have,
1329 -- and so it was decided to simply raise an exception. This does imply,
1330 -- however, that it is not possible to use a partial iterator to specify
1331 -- an empty sequence of items.
1333 if Start = No_Element then
1334 raise Constraint_Error with
1335 "Start position for iterator equals No_Element";
1338 if Start.Container /= Container'Unrestricted_Access then
1339 raise Program_Error with
1340 "Start cursor of Iterate designates wrong set";
1343 pragma Assert (Vet (Container.Tree, Start.Node),
1344 "Start cursor of Iterate is bad");
1346 -- The value of the Node component influences the behavior of the First
1347 -- and Last selector functions of the iterator object. When the Node
1348 -- component is non-null (as is the case here), it means that this is a
1349 -- partial iteration, over a subset of the complete sequence of
1350 -- items. The iterator object was constructed with a start expression,
1351 -- indicating the position from which the iteration begins. Note that
1352 -- the start position has the same value irrespective of whether this is
1353 -- a forward or reverse iteration.
1355 return It : constant Iterator :=
1356 (Limited_Controlled with S, Start.Node)
1366 function Last (Container : Set) return Cursor is
1368 if Container.Tree.Last = null then
1372 return Cursor'(Container
'Unrestricted_Access, Container
.Tree
.Last
);
1375 function Last
(Object
: Iterator
) return Cursor
is
1377 -- The value of the iterator object's Node component influences the
1378 -- behavior of the Last (and First) selector function.
1380 -- When the Node component is null, this means the iterator object was
1381 -- constructed without a start expression, in which case the (reverse)
1382 -- iteration starts from the (logical) beginning of the entire sequence
1383 -- (corresponding to Container.Last, for a reverse iterator).
1385 -- Otherwise, this is iteration over a partial sequence of items. When
1386 -- the Node component is non-null, the iterator object was constructed
1387 -- with a start expression, that specifies the position from which the
1388 -- (reverse) partial iteration begins.
1390 if Object
.Node
= null then
1391 return Object
.Container
.Last
;
1393 return Cursor
'(Object.Container, Object.Node);
1401 function Last_Element (Container : Set) return Element_Type is
1403 if Container.Tree.Last = null then
1404 raise Constraint_Error with "set is empty";
1407 return Container.Tree.Last.Element;
1414 function Left (Node : Node_Access) return Node_Access is
1423 function Length (Container : Set) return Count_Type is
1425 return Container.Tree.Length;
1433 new Tree_Operations.Generic_Move (Clear);
1435 procedure Move (Target : in out Set; Source : in out Set) is
1437 Move (Target => Target.Tree, Source => Source.Tree);
1444 procedure Next (Position : in out Cursor)
1447 Position := Next (Position);
1450 function Next (Position : Cursor) return Cursor is
1452 if Position = No_Element then
1456 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1457 "bad cursor in Next");
1460 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
1466 return Cursor'(Position
.Container
, Node
);
1470 function Next
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
1472 if Position
.Container
= null then
1476 if Position
.Container
/= Object
.Container
then
1477 raise Program_Error
with
1478 "Position cursor of Next designates wrong set";
1481 return Next
(Position
);
1488 function Overlap
(Left
, Right
: Set
) return Boolean is
1490 return Set_Ops
.Overlap
(Left
.Tree
, Right
.Tree
);
1497 function Parent
(Node
: Node_Access
) return Node_Access
is
1506 procedure Previous
(Position
: in out Cursor
)
1509 Position
:= Previous
(Position
);
1512 function Previous
(Position
: Cursor
) return Cursor
is
1514 if Position
= No_Element
then
1518 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1519 "bad cursor in Previous");
1522 Node
: constant Node_Access
:=
1523 Tree_Operations
.Previous
(Position
.Node
);
1525 return (if Node
= null then No_Element
1526 else Cursor
'(Position.Container, Node));
1530 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1532 if Position.Container = null then
1536 if Position.Container /= Object.Container then
1537 raise Program_Error with
1538 "Position cursor of Previous designates wrong set";
1541 return Previous (Position);
1548 procedure Query_Element
1550 Process : not null access procedure (Element : Element_Type))
1553 if Position.Node = null then
1554 raise Constraint_Error with "Position cursor equals No_Element";
1557 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1558 "bad cursor in Query_Element");
1561 T : Tree_Type renames Position.Container.Tree;
1562 Lock : With_Lock (T.TC'Unrestricted_Access);
1564 Process (Position.Node.Element);
1573 (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
1575 First_Time : Boolean := True;
1576 use System.Put_Images;
1582 First_Time := False;
1584 Simple_Array_Between (S);
1587 Element_Type'Put_Image (S, X);
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";
1640 (Stream : not null access Root_Stream_Type'Class;
1641 Item : out Constant_Reference_Type)
1644 raise Program_Error with "attempt to stream reference";
1647 ---------------------
1648 -- Replace_Element --
1649 ---------------------
1651 procedure Replace_Element
1652 (Tree : in out Tree_Type;
1654 Item : Element_Type)
1657 if Item < Node.Element
1658 or else Node.Element < Item
1664 Node.Element := Item;
1668 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
1670 Insert_New_Item : declare
1671 function New_Node return Node_Access;
1672 pragma Inline (New_Node);
1674 procedure Insert_Post is
1675 new Element_Keys.Generic_Insert_Post (New_Node);
1677 procedure Unconditional_Insert is
1678 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1684 function New_Node return Node_Access is
1686 Node.Element := Item;
1687 Node.Color := Red_Black_Trees.Red;
1688 Node.Parent := null;
1695 Result : Node_Access;
1697 -- Start of processing for Insert_New_Item
1700 Unconditional_Insert
1705 pragma Assert (Result = Node);
1706 end Insert_New_Item;
1707 end Replace_Element;
1709 procedure Replace_Element
1710 (Container : in out Set;
1712 New_Item : Element_Type)
1715 if Position.Node = null then
1716 raise Constraint_Error with
1717 "Position cursor equals No_Element";
1720 if Position.Container /= Container'Unrestricted_Access then
1721 raise Program_Error with
1722 "Position cursor designates wrong set";
1725 pragma Assert (Vet (Container.Tree, Position.Node),
1726 "bad cursor in Replace_Element");
1728 Replace_Element (Container.Tree, Position.Node, New_Item);
1729 end Replace_Element;
1731 ---------------------
1732 -- Reverse_Iterate --
1733 ---------------------
1735 procedure Reverse_Iterate
1737 Process : not null access procedure (Position : Cursor))
1739 procedure Process_Node (Node : Node_Access);
1740 pragma Inline (Process_Node);
1742 procedure Local_Reverse_Iterate is
1743 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1749 procedure Process_Node (Node : Node_Access) is
1751 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1754 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
1755 Busy
: With_Busy
(T
.TC
'Unrestricted_Access);
1757 -- Start of processing for Reverse_Iterate
1760 Local_Reverse_Iterate
(T
);
1761 end Reverse_Iterate
;
1763 procedure Reverse_Iterate
1765 Item
: Element_Type
;
1766 Process
: not null access procedure (Position
: Cursor
))
1768 procedure Process_Node
(Node
: Node_Access
);
1769 pragma Inline
(Process_Node
);
1771 procedure Local_Reverse_Iterate
is
1772 new Element_Keys
.Generic_Reverse_Iteration
(Process_Node
);
1778 procedure Process_Node
(Node
: Node_Access
) is
1780 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1783 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1784 Busy : With_Busy (T.TC'Unrestricted_Access);
1786 -- Start of processing for Reverse_Iterate
1789 Local_Reverse_Iterate (T, Item);
1790 end Reverse_Iterate;
1796 function Right (Node : Node_Access) return Node_Access is
1805 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1807 Node.Color := Color;
1814 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1823 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1825 Node.Parent := Parent;
1832 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1834 Node.Right := Right;
1837 --------------------------
1838 -- Symmetric_Difference --
1839 --------------------------
1841 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1843 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1844 end Symmetric_Difference;
1846 function Symmetric_Difference (Left, Right : Set) return Set is
1847 Tree : constant Tree_Type :=
1848 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1850 return Set'(Controlled
with Tree
);
1851 end Symmetric_Difference
;
1857 function To_Set
(New_Item
: Element_Type
) return Set
is
1861 Insert_Sans_Hint
(Tree
, New_Item
, Node
);
1862 return Set
'(Controlled with Tree);
1869 procedure Union (Target : in out Set; Source : Set) is
1871 Set_Ops.Union (Target.Tree, Source.Tree);
1874 function Union (Left, Right : Set) return Set is
1875 Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
1877 return Set'(Controlled
with Tree
);
1885 (Stream
: not null access Root_Stream_Type
'Class;
1888 procedure Write_Node
1889 (Stream
: not null access Root_Stream_Type
'Class;
1890 Node
: Node_Access
);
1891 pragma Inline
(Write_Node
);
1894 new Tree_Operations
.Generic_Write
(Write_Node
);
1900 procedure Write_Node
1901 (Stream
: not null access Root_Stream_Type
'Class;
1905 Element_Type
'Write (Stream
, Node
.Element
);
1908 -- Start of processing for Write
1911 Write
(Stream
, Container
.Tree
);
1915 (Stream
: not null access Root_Stream_Type
'Class;
1919 raise Program_Error
with "attempt to stream set cursor";
1923 (Stream
: not null access Root_Stream_Type
'Class;
1924 Item
: Constant_Reference_Type
)
1927 raise Program_Error
with "attempt to stream reference";
1929 end Ada
.Containers
.Ordered_Multisets
;