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-2015, 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 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
46 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
47 -- See comment in Ada.Containers.Helpers
49 -----------------------------
50 -- Node Access Subprograms --
51 -----------------------------
53 -- These subprograms provide a functional interface to access fields
54 -- of a node, and a procedural interface for modifying these values.
56 function Color
(Node
: Node_Access
) return Color_Type
;
57 pragma Inline
(Color
);
59 function Left
(Node
: Node_Access
) return Node_Access
;
62 function Parent
(Node
: Node_Access
) return Node_Access
;
63 pragma Inline
(Parent
);
65 function Right
(Node
: Node_Access
) return Node_Access
;
66 pragma Inline
(Right
);
68 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
69 pragma Inline
(Set_Parent
);
71 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
72 pragma Inline
(Set_Left
);
74 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
75 pragma Inline
(Set_Right
);
77 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
78 pragma Inline
(Set_Color
);
80 -----------------------
81 -- Local Subprograms --
82 -----------------------
84 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
85 pragma Inline
(Copy_Node
);
87 procedure Free
(X
: in out Node_Access
);
89 procedure Insert_Sans_Hint
90 (Tree
: in out Tree_Type
;
91 New_Item
: Element_Type
;
92 Node
: out Node_Access
);
94 procedure Insert_With_Hint
95 (Dst_Tree
: in out Tree_Type
;
96 Dst_Hint
: Node_Access
;
97 Src_Node
: Node_Access
;
98 Dst_Node
: out Node_Access
);
100 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean;
101 pragma Inline
(Is_Equal_Node_Node
);
103 function Is_Greater_Element_Node
104 (Left
: Element_Type
;
105 Right
: Node_Access
) return Boolean;
106 pragma Inline
(Is_Greater_Element_Node
);
108 function Is_Less_Element_Node
109 (Left
: Element_Type
;
110 Right
: Node_Access
) return Boolean;
111 pragma Inline
(Is_Less_Element_Node
);
113 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean;
114 pragma Inline
(Is_Less_Node_Node
);
116 procedure Replace_Element
117 (Tree
: in out Tree_Type
;
119 Item
: Element_Type
);
121 --------------------------
122 -- Local Instantiations --
123 --------------------------
125 package Tree_Operations
is
126 new Red_Black_Trees
.Generic_Operations
(Tree_Types
);
128 procedure Delete_Tree
is
129 new Tree_Operations
.Generic_Delete_Tree
(Free
);
131 function Copy_Tree
is
132 new Tree_Operations
.Generic_Copy_Tree
(Copy_Node
, Delete_Tree
);
137 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
139 package Element_Keys
is
140 new Red_Black_Trees
.Generic_Keys
141 (Tree_Operations
=> Tree_Operations
,
142 Key_Type
=> Element_Type
,
143 Is_Less_Key_Node
=> Is_Less_Element_Node
,
144 Is_Greater_Key_Node
=> Is_Greater_Element_Node
);
147 new Generic_Set_Operations
148 (Tree_Operations
=> Tree_Operations
,
149 Insert_With_Hint
=> Insert_With_Hint
,
150 Copy_Tree
=> Copy_Tree
,
151 Delete_Tree
=> Delete_Tree
,
152 Is_Less
=> Is_Less_Node_Node
,
159 function "<" (Left
, Right
: Cursor
) return Boolean is
161 if Left
.Node
= null then
162 raise Constraint_Error
with "Left cursor equals No_Element";
165 if Right
.Node
= null then
166 raise Constraint_Error
with "Right cursor equals No_Element";
169 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
170 "bad Left cursor in ""<""");
172 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
173 "bad Right cursor in ""<""");
175 return Left
.Node
.Element
< Right
.Node
.Element
;
178 function "<" (Left
: Cursor
; Right
: Element_Type
)
181 if Left
.Node
= null then
182 raise Constraint_Error
with "Left cursor equals No_Element";
185 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
186 "bad Left cursor in ""<""");
188 return Left
.Node
.Element
< Right
;
191 function "<" (Left
: Element_Type
; Right
: Cursor
)
194 if Right
.Node
= null then
195 raise Constraint_Error
with "Right cursor equals No_Element";
198 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
199 "bad Right cursor in ""<""");
201 return Left
< Right
.Node
.Element
;
208 function "=" (Left
, Right
: Set
) return Boolean is
210 return Is_Equal
(Left
.Tree
, Right
.Tree
);
217 function ">" (Left
, Right
: Cursor
) return Boolean is
219 if Left
.Node
= null then
220 raise Constraint_Error
with "Left cursor equals No_Element";
223 if Right
.Node
= null then
224 raise Constraint_Error
with "Right cursor equals No_Element";
227 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
228 "bad Left cursor in "">""");
230 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
231 "bad Right cursor in "">""");
233 -- L > R same as R < L
235 return Right
.Node
.Element
< Left
.Node
.Element
;
238 function ">" (Left
: Cursor
; Right
: Element_Type
)
241 if Left
.Node
= null then
242 raise Constraint_Error
with "Left cursor equals No_Element";
245 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
246 "bad Left cursor in "">""");
248 return Right
< Left
.Node
.Element
;
251 function ">" (Left
: Element_Type
; Right
: Cursor
)
254 if Right
.Node
= null then
255 raise Constraint_Error
with "Right cursor equals No_Element";
258 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
259 "bad Right cursor in "">""");
261 return Right
.Node
.Element
< Left
;
268 procedure Adjust
is new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
270 procedure Adjust
(Container
: in out Set
) is
272 Adjust
(Container
.Tree
);
279 procedure Assign
(Target
: in out Set
; Source
: Set
) is
281 if Target
'Address = Source
'Address then
286 Target
.Union
(Source
);
293 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
is
294 Node
: constant Node_Access
:=
295 Element_Keys
.Ceiling
(Container
.Tree
, Item
);
302 return Cursor
'(Container'Unrestricted_Access, Node);
310 new Tree_Operations.Generic_Clear (Delete_Tree);
312 procedure Clear (Container : in out Set) is
314 Clear (Container.Tree);
321 function Color (Node : Node_Access) return Color_Type is
326 ------------------------
327 -- Constant_Reference --
328 ------------------------
330 function Constant_Reference
331 (Container : aliased Set;
332 Position : Cursor) return Constant_Reference_Type
335 if Position.Container = null then
336 raise Constraint_Error with "Position cursor has no element";
339 if Position.Container /= Container'Unrestricted_Access then
340 raise Program_Error with
341 "Position cursor designates wrong container";
344 pragma Assert (Vet (Position.Container.Tree, Position.Node),
345 "bad cursor in Constant_Reference");
347 -- Note: in predefined container units, the creation of a reference
348 -- increments the busy bit of the container, and its finalization
349 -- decrements it. In the absence of control machinery, this tampering
350 -- protection is missing.
353 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
354 pragma Unreferenced (T);
356 return R : constant Constant_Reference_Type :=
357 (Element => Position.Node.Element'Unrestricted_Access,
358 Control => (Container => Container'Unrestricted_Access))
363 end Constant_Reference;
369 function Contains (Container : Set; Item : Element_Type) return Boolean is
371 return Find (Container, Item) /= No_Element;
378 function Copy (Source : Set) return Set is
380 return Target : Set do
381 Target.Assign (Source);
389 function Copy_Node (Source : Node_Access) return Node_Access is
390 Target : constant Node_Access :=
391 new Node_Type'(Parent
=> null,
394 Color
=> Source
.Color
,
395 Element
=> Source
.Element
);
404 procedure Delete
(Container
: in out Set
; Item
: Element_Type
) is
405 Tree
: Tree_Type
renames Container
.Tree
;
406 Node
: Node_Access
:= Element_Keys
.Ceiling
(Tree
, Item
);
407 Done
: constant Node_Access
:= Element_Keys
.Upper_Bound
(Tree
, Item
);
412 raise Constraint_Error
with
413 "attempt to delete element not in set";
418 Node
:= Tree_Operations
.Next
(Node
);
419 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
422 exit when Node
= Done
;
426 procedure Delete
(Container
: in out Set
; Position
: in out Cursor
) is
428 if Position
.Node
= null then
429 raise Constraint_Error
with "Position cursor equals No_Element";
432 if Position
.Container
/= Container
'Unrestricted_Access then
433 raise Program_Error
with "Position cursor designates wrong set";
436 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
437 "bad cursor in Delete");
439 Delete_Node_Sans_Free
(Container
.Tree
, Position
.Node
);
440 Free
(Position
.Node
);
442 Position
.Container
:= null;
449 procedure Delete_First
(Container
: in out Set
) is
450 Tree
: Tree_Type
renames Container
.Tree
;
451 X
: Node_Access
:= Tree
.First
;
458 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
466 procedure Delete_Last
(Container
: in out Set
) is
467 Tree
: Tree_Type
renames Container
.Tree
;
468 X
: Node_Access
:= Tree
.Last
;
475 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
483 procedure Difference
(Target
: in out Set
; Source
: Set
) is
485 Set_Ops
.Difference
(Target
.Tree
, Source
.Tree
);
488 function Difference
(Left
, Right
: Set
) return Set
is
489 Tree
: constant Tree_Type
:=
490 Set_Ops
.Difference
(Left
.Tree
, Right
.Tree
);
492 return Set
'(Controlled with Tree);
499 function Element (Position : Cursor) return Element_Type is
501 if Position.Node = null then
502 raise Constraint_Error with "Position cursor equals No_Element";
505 pragma Assert (Vet (Position.Container.Tree, Position.Node),
506 "bad cursor in Element");
508 return Position.Node.Element;
511 -------------------------
512 -- Equivalent_Elements --
513 -------------------------
515 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
524 end Equivalent_Elements;
526 ---------------------
527 -- Equivalent_Sets --
528 ---------------------
530 function Equivalent_Sets (Left, Right : Set) return Boolean is
532 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
533 pragma Inline (Is_Equivalent_Node_Node);
535 function Is_Equivalent is
536 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
538 -----------------------------
539 -- Is_Equivalent_Node_Node --
540 -----------------------------
542 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
544 if L.Element < R.Element then
546 elsif R.Element < L.Element then
551 end Is_Equivalent_Node_Node;
553 -- Start of processing for Equivalent_Sets
556 return Is_Equivalent (Left.Tree, Right.Tree);
563 procedure Exclude (Container : in out Set; Item : Element_Type) is
564 Tree : Tree_Type renames Container.Tree;
565 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
566 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
569 while Node /= Done loop
571 Node := Tree_Operations.Next (Node);
572 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
581 procedure Finalize (Object : in out Iterator) is
583 Unbusy (Object.Container.Tree.TC);
590 function Find (Container : Set; Item : Element_Type) return Cursor is
591 Node : constant Node_Access :=
592 Element_Keys.Find (Container.Tree, Item);
599 return Cursor'(Container
'Unrestricted_Access, Node
);
606 function First
(Container
: Set
) return Cursor
is
608 if Container
.Tree
.First
= null then
612 return Cursor
'(Container'Unrestricted_Access, Container.Tree.First);
615 function First (Object : Iterator) return Cursor is
617 -- The value of the iterator object's Node component influences the
618 -- behavior of the First (and Last) selector function.
620 -- When the Node component is null, this means the iterator object was
621 -- constructed without a start expression, in which case the (forward)
622 -- iteration starts from the (logical) beginning of the entire sequence
623 -- of items (corresponding to Container.First, for a forward iterator).
625 -- Otherwise, this is iteration over a partial sequence of items. When
626 -- the Node component is non-null, the iterator object was constructed
627 -- with a start expression, that specifies the position from which the
628 -- (forward) partial iteration begins.
630 if Object.Node = null then
631 return Object.Container.First;
633 return Cursor'(Object
.Container
, Object
.Node
);
641 function First_Element
(Container
: Set
) return Element_Type
is
643 if Container
.Tree
.First
= null then
644 raise Constraint_Error
with "set is empty";
647 return Container
.Tree
.First
.Element
;
654 function Floor
(Container
: Set
; Item
: Element_Type
) return Cursor
is
655 Node
: constant Node_Access
:=
656 Element_Keys
.Floor
(Container
.Tree
, Item
);
663 return Cursor
'(Container'Unrestricted_Access, Node);
670 procedure Free (X : in out Node_Access) is
671 procedure Deallocate is
672 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
688 package body Generic_Keys is
690 -----------------------
691 -- Local Subprograms --
692 -----------------------
694 function Is_Greater_Key_Node
696 Right : Node_Access) return Boolean;
697 pragma Inline (Is_Greater_Key_Node);
699 function Is_Less_Key_Node
701 Right : Node_Access) return Boolean;
702 pragma Inline (Is_Less_Key_Node);
704 --------------------------
705 -- Local_Instantiations --
706 --------------------------
709 new Red_Black_Trees.Generic_Keys
710 (Tree_Operations => Tree_Operations,
711 Key_Type => Key_Type,
712 Is_Less_Key_Node => Is_Less_Key_Node,
713 Is_Greater_Key_Node => Is_Greater_Key_Node);
719 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
720 Node : constant Node_Access :=
721 Key_Keys.Ceiling (Container.Tree, Key);
728 return Cursor'(Container
'Unrestricted_Access, Node
);
735 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean is
737 return Find
(Container
, Key
) /= No_Element
;
744 procedure Delete
(Container
: in out Set
; Key
: Key_Type
) is
745 Tree
: Tree_Type
renames Container
.Tree
;
746 Node
: Node_Access
:= Key_Keys
.Ceiling
(Tree
, Key
);
747 Done
: constant Node_Access
:= Key_Keys
.Upper_Bound
(Tree
, Key
);
752 raise Constraint_Error
with "attempt to delete key not in set";
757 Node
:= Tree_Operations
.Next
(Node
);
758 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
761 exit when Node
= Done
;
769 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
is
770 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
773 raise Constraint_Error
with "key not in set";
779 ---------------------
780 -- Equivalent_Keys --
781 ---------------------
783 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
798 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
) is
799 Tree
: Tree_Type
renames Container
.Tree
;
800 Node
: Node_Access
:= Key_Keys
.Ceiling
(Tree
, Key
);
801 Done
: constant Node_Access
:= Key_Keys
.Upper_Bound
(Tree
, Key
);
805 while Node
/= Done
loop
807 Node
:= Tree_Operations
.Next
(Node
);
808 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
817 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
is
818 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
825 return Cursor
'(Container'Unrestricted_Access, Node);
832 function Floor (Container : Set; Key : Key_Type) return Cursor is
833 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
840 return Cursor'(Container
'Unrestricted_Access, Node
);
843 -------------------------
844 -- Is_Greater_Key_Node --
845 -------------------------
847 function Is_Greater_Key_Node
849 Right
: Node_Access
) return Boolean is
851 return Key
(Right
.Element
) < Left
;
852 end Is_Greater_Key_Node
;
854 ----------------------
855 -- Is_Less_Key_Node --
856 ----------------------
858 function Is_Less_Key_Node
860 Right
: Node_Access
) return Boolean is
862 return Left
< Key
(Right
.Element
);
863 end Is_Less_Key_Node
;
872 Process
: not null access procedure (Position
: Cursor
))
874 procedure Process_Node
(Node
: Node_Access
);
875 pragma Inline
(Process_Node
);
877 procedure Local_Iterate
is
878 new Key_Keys
.Generic_Iteration
(Process_Node
);
884 procedure Process_Node
(Node
: Node_Access
) is
886 Process
(Cursor
'(Container'Unrestricted_Access, Node));
889 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
890 Busy : With_Busy (T.TC'Unrestricted_Access);
892 -- Start of processing for Iterate
895 Local_Iterate (T, Key);
902 function Key (Position : Cursor) return Key_Type is
904 if Position.Node = null then
905 raise Constraint_Error with
906 "Position cursor equals No_Element";
909 pragma Assert (Vet (Position.Container.Tree, Position.Node),
910 "bad cursor in Key");
912 return Key (Position.Node.Element);
915 ---------------------
916 -- Reverse_Iterate --
917 ---------------------
919 procedure Reverse_Iterate
922 Process : not null access procedure (Position : Cursor))
924 procedure Process_Node (Node : Node_Access);
925 pragma Inline (Process_Node);
927 procedure Local_Reverse_Iterate is
928 new Key_Keys.Generic_Reverse_Iteration (Process_Node);
934 procedure Process_Node (Node : Node_Access) is
936 Process (Cursor'(Container
'Unrestricted_Access, Node
));
939 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
940 Busy
: With_Busy
(T
.TC
'Unrestricted_Access);
942 -- Start of processing for Reverse_Iterate
945 Local_Reverse_Iterate
(T
, Key
);
952 procedure Update_Element
953 (Container
: in out Set
;
955 Process
: not null access procedure (Element
: in out Element_Type
))
957 Tree
: Tree_Type
renames Container
.Tree
;
958 Node
: constant Node_Access
:= Position
.Node
;
962 raise Constraint_Error
with
963 "Position cursor equals No_Element";
966 if Position
.Container
/= Container
'Unrestricted_Access then
967 raise Program_Error
with
968 "Position cursor designates wrong set";
971 pragma Assert
(Vet
(Tree
, Node
),
972 "bad cursor in Update_Element");
975 E
: Element_Type
renames Node
.Element
;
976 K
: constant Key_Type
:= Key
(E
);
977 Lock
: With_Lock
(Tree
.TC
'Unrestricted_Access);
981 if Equivalent_Keys
(Left
=> K
, Right
=> Key
(E
)) then
986 -- Delete_Node checks busy-bit
988 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Node
);
990 Insert_New_Item
: declare
991 function New_Node
return Node_Access
;
992 pragma Inline
(New_Node
);
994 procedure Insert_Post
is
995 new Element_Keys
.Generic_Insert_Post
(New_Node
);
997 procedure Unconditional_Insert
is
998 new Element_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
1004 function New_Node
return Node_Access
is
1006 Node
.Color
:= Red_Black_Trees
.Red
;
1007 Node
.Parent
:= null;
1014 Result
: Node_Access
;
1016 -- Start of processing for Insert_New_Item
1019 Unconditional_Insert
1021 Key
=> Node
.Element
,
1024 pragma Assert
(Result
= Node
);
1025 end Insert_New_Item
;
1034 function Has_Element
(Position
: Cursor
) return Boolean is
1036 return Position
/= No_Element
;
1043 procedure Insert
(Container
: in out Set
; New_Item
: Element_Type
) is
1045 pragma Unreferenced
(Position
);
1047 Insert
(Container
, New_Item
, Position
);
1051 (Container
: in out Set
;
1052 New_Item
: Element_Type
;
1053 Position
: out Cursor
)
1056 Insert_Sans_Hint
(Container
.Tree
, New_Item
, Position
.Node
);
1057 Position
.Container
:= Container
'Unrestricted_Access;
1060 ----------------------
1061 -- Insert_Sans_Hint --
1062 ----------------------
1064 procedure Insert_Sans_Hint
1065 (Tree
: in out Tree_Type
;
1066 New_Item
: Element_Type
;
1067 Node
: out Node_Access
)
1069 function New_Node
return Node_Access
;
1070 pragma Inline
(New_Node
);
1072 procedure Insert_Post
is
1073 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1075 procedure Unconditional_Insert
is
1076 new Element_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
1082 function New_Node
return Node_Access
is
1083 Node
: constant Node_Access
:=
1084 new Node_Type
'(Parent => null,
1087 Color => Red_Black_Trees.Red,
1088 Element => New_Item);
1093 -- Start of processing for Insert_Sans_Hint
1096 Unconditional_Insert (Tree, New_Item, Node);
1097 end Insert_Sans_Hint;
1099 ----------------------
1100 -- Insert_With_Hint --
1101 ----------------------
1103 procedure Insert_With_Hint
1104 (Dst_Tree : in out Tree_Type;
1105 Dst_Hint : Node_Access;
1106 Src_Node : Node_Access;
1107 Dst_Node : out Node_Access)
1109 function New_Node return Node_Access;
1110 pragma Inline (New_Node);
1112 procedure Insert_Post is
1113 new Element_Keys.Generic_Insert_Post (New_Node);
1115 procedure Insert_Sans_Hint is
1116 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1118 procedure Local_Insert_With_Hint is
1119 new Element_Keys.Generic_Unconditional_Insert_With_Hint
1127 function New_Node return Node_Access is
1128 Node : constant Node_Access :=
1129 new Node_Type'(Parent
=> null,
1133 Element
=> Src_Node
.Element
);
1138 -- Start of processing for Insert_With_Hint
1141 Local_Insert_With_Hint
1146 end Insert_With_Hint
;
1152 procedure Intersection
(Target
: in out Set
; Source
: Set
) is
1154 Set_Ops
.Intersection
(Target
.Tree
, Source
.Tree
);
1157 function Intersection
(Left
, Right
: Set
) return Set
is
1158 Tree
: constant Tree_Type
:=
1159 Set_Ops
.Intersection
(Left
.Tree
, Right
.Tree
);
1161 return Set
'(Controlled with Tree);
1168 function Is_Empty (Container : Set) return Boolean is
1170 return Container.Tree.Length = 0;
1173 ------------------------
1174 -- Is_Equal_Node_Node --
1175 ------------------------
1177 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1179 return L.Element = R.Element;
1180 end Is_Equal_Node_Node;
1182 -----------------------------
1183 -- Is_Greater_Element_Node --
1184 -----------------------------
1186 function Is_Greater_Element_Node
1187 (Left : Element_Type;
1188 Right : Node_Access) return Boolean
1191 -- e > node same as node < e
1193 return Right.Element < Left;
1194 end Is_Greater_Element_Node;
1196 --------------------------
1197 -- Is_Less_Element_Node --
1198 --------------------------
1200 function Is_Less_Element_Node
1201 (Left : Element_Type;
1202 Right : Node_Access) return Boolean
1205 return Left < Right.Element;
1206 end Is_Less_Element_Node;
1208 -----------------------
1209 -- Is_Less_Node_Node --
1210 -----------------------
1212 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1214 return L.Element < R.Element;
1215 end Is_Less_Node_Node;
1221 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1223 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1232 Process : not null access procedure (Position : Cursor))
1234 procedure Process_Node (Node : Node_Access);
1235 pragma Inline (Process_Node);
1237 procedure Local_Iterate is
1238 new Tree_Operations.Generic_Iteration (Process_Node);
1244 procedure Process_Node (Node : Node_Access) is
1246 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1249 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
1250 Busy
: With_Busy
(T
.TC
'Unrestricted_Access);
1252 -- Start of processing for Iterate
1260 Item
: Element_Type
;
1261 Process
: not null access procedure (Position
: Cursor
))
1263 procedure Process_Node
(Node
: Node_Access
);
1264 pragma Inline
(Process_Node
);
1266 procedure Local_Iterate
is
1267 new Element_Keys
.Generic_Iteration
(Process_Node
);
1273 procedure Process_Node
(Node
: Node_Access
) is
1275 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1278 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1279 Busy : With_Busy (T.TC'Unrestricted_Access);
1281 -- Start of processing for Iterate
1284 Local_Iterate (T, Item);
1287 function Iterate (Container : Set)
1288 return Set_Iterator_Interfaces.Reversible_Iterator'Class
1290 S : constant Set_Access := Container'Unrestricted_Access;
1292 -- The value of the Node component influences the behavior of the First
1293 -- and Last selector functions of the iterator object. When the Node
1294 -- component is null (as is the case here), this means the iterator
1295 -- object was constructed without a start expression. This is a complete
1296 -- iterator, meaning that the iteration starts from the (logical)
1297 -- beginning of the sequence of items.
1299 -- Note: For a forward iterator, Container.First is the beginning, and
1300 -- for a reverse iterator, Container.Last is the beginning.
1302 return It : constant Iterator := (Limited_Controlled with S, null) do
1307 function Iterate (Container : Set; Start : Cursor)
1308 return Set_Iterator_Interfaces.Reversible_Iterator'Class
1310 S : constant Set_Access := Container'Unrestricted_Access;
1312 -- It was formerly the case that when Start = No_Element, the partial
1313 -- iterator was defined to behave the same as for a complete iterator,
1314 -- and iterate over the entire sequence of items. However, those
1315 -- semantics were unintuitive and arguably error-prone (it is too easy
1316 -- to accidentally create an endless loop), and so they were changed,
1317 -- per the ARG meeting in Denver on 2011/11. However, there was no
1318 -- consensus about what positive meaning this corner case should have,
1319 -- and so it was decided to simply raise an exception. This does imply,
1320 -- however, that it is not possible to use a partial iterator to specify
1321 -- an empty sequence of items.
1323 if Start = No_Element then
1324 raise Constraint_Error with
1325 "Start position for iterator equals No_Element";
1328 if Start.Container /= Container'Unrestricted_Access then
1329 raise Program_Error with
1330 "Start cursor of Iterate designates wrong set";
1333 pragma Assert (Vet (Container.Tree, Start.Node),
1334 "Start cursor of Iterate is bad");
1336 -- The value of the Node component influences the behavior of the First
1337 -- and Last selector functions of the iterator object. When the Node
1338 -- component is non-null (as is the case here), it means that this is a
1339 -- partial iteration, over a subset of the complete sequence of
1340 -- items. The iterator object was constructed with a start expression,
1341 -- indicating the position from which the iteration begins. Note that
1342 -- the start position has the same value irrespective of whether this is
1343 -- a forward or reverse iteration.
1345 return It : constant Iterator :=
1346 (Limited_Controlled with S, Start.Node)
1356 function Last (Container : Set) return Cursor is
1358 if Container.Tree.Last = null then
1362 return Cursor'(Container
'Unrestricted_Access, Container
.Tree
.Last
);
1365 function Last
(Object
: Iterator
) return Cursor
is
1367 -- The value of the iterator object's Node component influences the
1368 -- behavior of the Last (and First) selector function.
1370 -- When the Node component is null, this means the iterator object was
1371 -- constructed without a start expression, in which case the (reverse)
1372 -- iteration starts from the (logical) beginning of the entire sequence
1373 -- (corresponding to Container.Last, for a reverse iterator).
1375 -- Otherwise, this is iteration over a partial sequence of items. When
1376 -- the Node component is non-null, the iterator object was constructed
1377 -- with a start expression, that specifies the position from which the
1378 -- (reverse) partial iteration begins.
1380 if Object
.Node
= null then
1381 return Object
.Container
.Last
;
1383 return Cursor
'(Object.Container, Object.Node);
1391 function Last_Element (Container : Set) return Element_Type is
1393 if Container.Tree.Last = null then
1394 raise Constraint_Error with "set is empty";
1397 return Container.Tree.Last.Element;
1404 function Left (Node : Node_Access) return Node_Access is
1413 function Length (Container : Set) return Count_Type is
1415 return Container.Tree.Length;
1423 new Tree_Operations.Generic_Move (Clear);
1425 procedure Move (Target : in out Set; Source : in out Set) is
1427 Move (Target => Target.Tree, Source => Source.Tree);
1434 procedure Next (Position : in out Cursor)
1437 Position := Next (Position);
1440 function Next (Position : Cursor) return Cursor is
1442 if Position = No_Element then
1446 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1447 "bad cursor in Next");
1450 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
1456 return Cursor'(Position
.Container
, Node
);
1460 function Next
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
1462 if Position
.Container
= null then
1466 if Position
.Container
/= Object
.Container
then
1467 raise Program_Error
with
1468 "Position cursor of Next designates wrong set";
1471 return Next
(Position
);
1478 function Overlap
(Left
, Right
: Set
) return Boolean is
1480 return Set_Ops
.Overlap
(Left
.Tree
, Right
.Tree
);
1487 function Parent
(Node
: Node_Access
) return Node_Access
is
1496 procedure Previous
(Position
: in out Cursor
)
1499 Position
:= Previous
(Position
);
1502 function Previous
(Position
: Cursor
) return Cursor
is
1504 if Position
= No_Element
then
1508 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1509 "bad cursor in Previous");
1512 Node
: constant Node_Access
:=
1513 Tree_Operations
.Previous
(Position
.Node
);
1515 return (if Node
= null then No_Element
1516 else Cursor
'(Position.Container, Node));
1520 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1522 if Position.Container = null then
1526 if Position.Container /= Object.Container then
1527 raise Program_Error with
1528 "Position cursor of Previous designates wrong set";
1531 return Previous (Position);
1538 procedure Query_Element
1540 Process : not null access procedure (Element : Element_Type))
1543 if Position.Node = null then
1544 raise Constraint_Error with "Position cursor equals No_Element";
1547 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1548 "bad cursor in Query_Element");
1551 T : Tree_Type renames Position.Container.Tree;
1552 Lock : With_Lock (T.TC'Unrestricted_Access);
1554 Process (Position.Node.Element);
1563 (Stream : not null access Root_Stream_Type'Class;
1564 Container : out Set)
1567 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1568 pragma Inline (Read_Node);
1571 new Tree_Operations.Generic_Read (Clear, Read_Node);
1578 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1580 Node : Node_Access := new Node_Type;
1582 Element_Type'Read (Stream, Node.Element);
1586 Free (Node); -- Note that Free deallocates elem too
1590 -- Start of processing for Read
1593 Read (Stream, Container.Tree);
1597 (Stream : not null access Root_Stream_Type'Class;
1601 raise Program_Error with "attempt to stream set cursor";
1605 (Stream : not null access Root_Stream_Type'Class;
1606 Item : out Constant_Reference_Type)
1609 raise Program_Error with "attempt to stream reference";
1612 ---------------------
1613 -- Replace_Element --
1614 ---------------------
1616 procedure Replace_Element
1617 (Tree : in out Tree_Type;
1619 Item : Element_Type)
1622 if Item < Node.Element
1623 or else Node.Element < Item
1629 Node.Element := Item;
1633 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
1635 Insert_New_Item : declare
1636 function New_Node return Node_Access;
1637 pragma Inline (New_Node);
1639 procedure Insert_Post is
1640 new Element_Keys.Generic_Insert_Post (New_Node);
1642 procedure Unconditional_Insert is
1643 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1649 function New_Node return Node_Access is
1651 Node.Element := Item;
1652 Node.Color := Red_Black_Trees.Red;
1653 Node.Parent := null;
1660 Result : Node_Access;
1662 -- Start of processing for Insert_New_Item
1665 Unconditional_Insert
1670 pragma Assert (Result = Node);
1671 end Insert_New_Item;
1672 end Replace_Element;
1674 procedure Replace_Element
1675 (Container : in out Set;
1677 New_Item : Element_Type)
1680 if Position.Node = null then
1681 raise Constraint_Error with
1682 "Position cursor equals No_Element";
1685 if Position.Container /= Container'Unrestricted_Access then
1686 raise Program_Error with
1687 "Position cursor designates wrong set";
1690 pragma Assert (Vet (Container.Tree, Position.Node),
1691 "bad cursor in Replace_Element");
1693 Replace_Element (Container.Tree, Position.Node, New_Item);
1694 end Replace_Element;
1696 ---------------------
1697 -- Reverse_Iterate --
1698 ---------------------
1700 procedure Reverse_Iterate
1702 Process : not null access procedure (Position : Cursor))
1704 procedure Process_Node (Node : Node_Access);
1705 pragma Inline (Process_Node);
1707 procedure Local_Reverse_Iterate is
1708 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1714 procedure Process_Node (Node : Node_Access) is
1716 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1719 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
1720 Busy
: With_Busy
(T
.TC
'Unrestricted_Access);
1722 -- Start of processing for Reverse_Iterate
1725 Local_Reverse_Iterate
(T
);
1726 end Reverse_Iterate
;
1728 procedure Reverse_Iterate
1730 Item
: Element_Type
;
1731 Process
: not null access procedure (Position
: Cursor
))
1733 procedure Process_Node
(Node
: Node_Access
);
1734 pragma Inline
(Process_Node
);
1736 procedure Local_Reverse_Iterate
is
1737 new Element_Keys
.Generic_Reverse_Iteration
(Process_Node
);
1743 procedure Process_Node
(Node
: Node_Access
) is
1745 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1748 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1749 Busy : With_Busy (T.TC'Unrestricted_Access);
1751 -- Start of processing for Reverse_Iterate
1754 Local_Reverse_Iterate (T, Item);
1755 end Reverse_Iterate;
1761 function Right (Node : Node_Access) return Node_Access is
1770 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1772 Node.Color := Color;
1779 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1788 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1790 Node.Parent := Parent;
1797 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1799 Node.Right := Right;
1802 --------------------------
1803 -- Symmetric_Difference --
1804 --------------------------
1806 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1808 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1809 end Symmetric_Difference;
1811 function Symmetric_Difference (Left, Right : Set) return Set is
1812 Tree : constant Tree_Type :=
1813 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1815 return Set'(Controlled
with Tree
);
1816 end Symmetric_Difference
;
1822 function To_Set
(New_Item
: Element_Type
) return Set
is
1825 pragma Unreferenced
(Node
);
1827 Insert_Sans_Hint
(Tree
, New_Item
, Node
);
1828 return Set
'(Controlled with Tree);
1835 procedure Union (Target : in out Set; Source : Set) is
1837 Set_Ops.Union (Target.Tree, Source.Tree);
1840 function Union (Left, Right : Set) return Set is
1841 Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
1843 return Set'(Controlled
with Tree
);
1851 (Stream
: not null access Root_Stream_Type
'Class;
1854 procedure Write_Node
1855 (Stream
: not null access Root_Stream_Type
'Class;
1856 Node
: Node_Access
);
1857 pragma Inline
(Write_Node
);
1860 new Tree_Operations
.Generic_Write
(Write_Node
);
1866 procedure Write_Node
1867 (Stream
: not null access Root_Stream_Type
'Class;
1871 Element_Type
'Write (Stream
, Node
.Element
);
1874 -- Start of processing for Write
1877 Write
(Stream
, Container
.Tree
);
1881 (Stream
: not null access Root_Stream_Type
'Class;
1885 raise Program_Error
with "attempt to stream set cursor";
1889 (Stream
: not null access Root_Stream_Type
'Class;
1890 Item
: Constant_Reference_Type
)
1893 raise Program_Error
with "attempt to stream reference";
1895 end Ada
.Containers
.Ordered_Multisets
;