1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS --
9 -- Copyright (C) 2004-2023, 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
.Indefinite_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
);
139 procedure Free_Element
is
140 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
143 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
146 new Generic_Set_Operations
147 (Tree_Operations
=> Tree_Operations
,
148 Insert_With_Hint
=> Insert_With_Hint
,
149 Copy_Tree
=> Copy_Tree
,
150 Delete_Tree
=> Delete_Tree
,
151 Is_Less
=> Is_Less_Node_Node
,
154 package Element_Keys
is
155 new Red_Black_Trees
.Generic_Keys
156 (Tree_Operations
=> Tree_Operations
,
157 Key_Type
=> Element_Type
,
158 Is_Less_Key_Node
=> Is_Less_Element_Node
,
159 Is_Greater_Key_Node
=> Is_Greater_Element_Node
);
165 function "<" (Left
, Right
: Cursor
) return Boolean is
167 if Left
.Node
= null then
168 raise Constraint_Error
with "Left cursor equals No_Element";
171 if Right
.Node
= null then
172 raise Constraint_Error
with "Right cursor equals No_Element";
175 if Left
.Node
.Element
= null then
176 raise Program_Error
with "Left cursor is bad";
179 if Right
.Node
.Element
= null then
180 raise Program_Error
with "Right cursor is bad";
183 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
184 "bad Left cursor in ""<""");
186 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
187 "bad Right cursor in ""<""");
189 return Left
.Node
.Element
.all < Right
.Node
.Element
.all;
192 function "<" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
194 if Left
.Node
= null then
195 raise Constraint_Error
with "Left cursor equals No_Element";
198 if Left
.Node
.Element
= null then
199 raise Program_Error
with "Left cursor is bad";
202 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
203 "bad Left cursor in ""<""");
205 return Left
.Node
.Element
.all < Right
;
208 function "<" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
210 if Right
.Node
= null then
211 raise Constraint_Error
with "Right cursor equals No_Element";
214 if Right
.Node
.Element
= null then
215 raise Program_Error
with "Right cursor is bad";
218 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
219 "bad Right cursor in ""<""");
221 return Left
< Right
.Node
.Element
.all;
228 function "=" (Left
, Right
: Set
) return Boolean is
230 return Is_Equal
(Left
.Tree
, Right
.Tree
);
237 function ">" (Left
, Right
: Cursor
) return Boolean is
239 if Left
.Node
= null then
240 raise Constraint_Error
with "Left cursor equals No_Element";
243 if Right
.Node
= null then
244 raise Constraint_Error
with "Right cursor equals No_Element";
247 if Left
.Node
.Element
= null then
248 raise Program_Error
with "Left cursor is bad";
251 if Right
.Node
.Element
= null then
252 raise Program_Error
with "Right cursor is bad";
255 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
256 "bad Left cursor in "">""");
258 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
259 "bad Right cursor in "">""");
261 -- L > R same as R < L
263 return Right
.Node
.Element
.all < Left
.Node
.Element
.all;
266 function ">" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
268 if Left
.Node
= null then
269 raise Constraint_Error
with "Left cursor equals No_Element";
272 if Left
.Node
.Element
= null then
273 raise Program_Error
with "Left cursor is bad";
276 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
277 "bad Left cursor in "">""");
279 return Right
< Left
.Node
.Element
.all;
282 function ">" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
284 if Right
.Node
= null then
285 raise Constraint_Error
with "Right cursor equals No_Element";
288 if Right
.Node
.Element
= null then
289 raise Program_Error
with "Right cursor is bad";
292 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
293 "bad Right cursor in "">""");
295 return Right
.Node
.Element
.all < Left
;
303 new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
305 procedure Adjust
(Container
: in out Set
) is
307 Adjust
(Container
.Tree
);
314 procedure Assign
(Target
: in out Set
; Source
: Set
) is
316 if Target
'Address = Source
'Address then
321 Target
.Union
(Source
);
328 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
is
329 Node
: constant Node_Access
:=
330 Element_Keys
.Ceiling
(Container
.Tree
, Item
);
337 return Cursor
'(Container'Unrestricted_Access, Node);
345 new Tree_Operations.Generic_Clear (Delete_Tree);
347 procedure Clear (Container : in out Set) is
349 Clear (Container.Tree);
356 function Color (Node : Node_Access) return Color_Type is
361 ------------------------
362 -- Constant_Reference --
363 ------------------------
365 function Constant_Reference
366 (Container : aliased Set;
367 Position : Cursor) return Constant_Reference_Type
370 if Position.Container = null then
371 raise Constraint_Error with "Position cursor has no element";
374 if Position.Container /= Container'Unrestricted_Access then
375 raise Program_Error with
376 "Position cursor designates wrong container";
379 pragma Assert (Vet (Position.Container.Tree, Position.Node),
380 "bad cursor in Constant_Reference");
382 -- Note: in predefined container units, the creation of a reference
383 -- increments the busy bit of the container, and its finalization
384 -- decrements it. In the absence of control machinery, this tampering
385 -- protection is missing.
388 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
389 pragma Unreferenced (T);
391 return R : constant Constant_Reference_Type :=
392 (Element => Position.Node.Element,
393 Control => (Container => Container'Unrestricted_Access))
398 end Constant_Reference;
404 function Contains (Container : Set; Item : Element_Type) return Boolean is
406 return Find (Container, Item) /= No_Element;
413 function Copy (Source : Set) return Set is
415 return Target : Set do
416 Target.Assign (Source);
424 function Copy_Node (Source : Node_Access) return Node_Access is
425 X : Element_Access := new Element_Type'(Source
.Element
.all);
428 return new Node_Type
'(Parent => null,
431 Color => Source.Color,
444 procedure Delete (Container : in out Set; Item : Element_Type) is
445 Tree : Tree_Type renames Container.Tree;
446 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
447 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
452 raise Constraint_Error with "attempt to delete element not in set";
457 Node := Tree_Operations.Next (Node);
458 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
461 exit when Node = Done;
465 procedure Delete (Container : in out Set; Position : in out Cursor) is
467 if Position.Node = null then
468 raise Constraint_Error with "Position cursor equals No_Element";
471 if Position.Node.Element = null then
472 raise Program_Error with "Position cursor is bad";
475 if Position.Container /= Container'Unrestricted_Access then
476 raise Program_Error with "Position cursor designates wrong set";
479 pragma Assert (Vet (Container.Tree, Position.Node),
480 "bad cursor in Delete");
482 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
483 Free (Position.Node);
485 Position.Container := null;
492 procedure Delete_First (Container : in out Set) is
493 Tree : Tree_Type renames Container.Tree;
494 X : Node_Access := Tree.First;
501 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
509 procedure Delete_Last (Container : in out Set) is
510 Tree : Tree_Type renames Container.Tree;
511 X : Node_Access := Tree.Last;
518 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
526 procedure Difference (Target : in out Set; Source : Set) is
528 Set_Ops.Difference (Target.Tree, Source.Tree);
531 function Difference (Left, Right : Set) return Set is
532 Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree);
534 return Set'(Controlled
with Tree
);
541 function Element
(Position
: Cursor
) return Element_Type
is
543 if Position
.Node
= null then
544 raise Constraint_Error
with "Position cursor equals No_Element";
547 if Position
.Node
.Element
= null then
548 raise Program_Error
with "Position cursor is bad";
552 and then (Left
(Position
.Node
) = Position
.Node
554 Right
(Position
.Node
) = Position
.Node
)
556 raise Program_Error
with "dangling cursor";
559 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
560 "bad cursor in Element");
562 return Position
.Node
.Element
.all;
565 -------------------------
566 -- Equivalent_Elements --
567 -------------------------
569 function Equivalent_Elements
(Left
, Right
: Element_Type
) return Boolean is
578 end Equivalent_Elements
;
580 ---------------------
581 -- Equivalent_Sets --
582 ---------------------
584 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
586 function Is_Equivalent_Node_Node
(L
, R
: Node_Access
) return Boolean;
587 pragma Inline
(Is_Equivalent_Node_Node
);
589 function Is_Equivalent
is
590 new Tree_Operations
.Generic_Equal
(Is_Equivalent_Node_Node
);
592 -----------------------------
593 -- Is_Equivalent_Node_Node --
594 -----------------------------
596 function Is_Equivalent_Node_Node
(L
, R
: Node_Access
) return Boolean is
598 if L
.Element
.all < R
.Element
.all then
600 elsif R
.Element
.all < L
.Element
.all then
605 end Is_Equivalent_Node_Node
;
607 -- Start of processing for Equivalent_Sets
610 return Is_Equivalent
(Left
.Tree
, Right
.Tree
);
617 procedure Exclude
(Container
: in out Set
; Item
: Element_Type
) is
618 Tree
: Tree_Type
renames Container
.Tree
;
619 Node
: Node_Access
:= Element_Keys
.Ceiling
(Tree
, Item
);
620 Done
: constant Node_Access
:= Element_Keys
.Upper_Bound
(Tree
, Item
);
624 while Node
/= Done
loop
626 Node
:= Tree_Operations
.Next
(Node
);
627 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
636 function Find
(Container
: Set
; Item
: Element_Type
) return Cursor
is
637 Node
: constant Node_Access
:= Element_Keys
.Find
(Container
.Tree
, Item
);
644 return Cursor
'(Container'Unrestricted_Access, Node);
651 procedure Finalize (Object : in out Iterator) is
653 Unbusy (Object.Container.Tree.TC);
660 function First (Container : Set) return Cursor is
662 if Container.Tree.First = null then
666 return Cursor'(Container
'Unrestricted_Access, Container
.Tree
.First
);
669 function First
(Object
: Iterator
) return Cursor
is
671 -- The value of the iterator object's Node component influences the
672 -- behavior of the First (and Last) selector function.
674 -- When the Node component is null, this means the iterator object was
675 -- constructed without a start expression, in which case the (forward)
676 -- iteration starts from the (logical) beginning of the entire sequence
677 -- of items (corresponding to Container.First, for a forward iterator).
679 -- Otherwise, this is iteration over a partial sequence of items. When
680 -- the Node component is non-null, the iterator object was constructed
681 -- with a start expression, that specifies the position from which the
682 -- (forward) partial iteration begins.
684 if Object
.Node
= null then
685 return Object
.Container
.First
;
687 return Cursor
'(Object.Container, Object.Node);
695 function First_Element (Container : Set) return Element_Type is
697 if Container.Tree.First = null then
698 raise Constraint_Error with "set is empty";
701 pragma Assert (Container.Tree.First.Element /= null);
702 return Container.Tree.First.Element.all;
709 function Floor (Container : Set; Item : Element_Type) return Cursor is
710 Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item);
717 return Cursor'(Container
'Unrestricted_Access, Node
);
724 procedure Free
(X
: in out Node_Access
) is
725 procedure Deallocate
is
726 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
738 Free_Element
(X
.Element
);
753 package body Generic_Keys
is
755 -----------------------
756 -- Local Subprograms --
757 -----------------------
759 function Is_Less_Key_Node
761 Right
: Node_Access
) return Boolean;
762 pragma Inline
(Is_Less_Key_Node
);
764 function Is_Greater_Key_Node
766 Right
: Node_Access
) return Boolean;
767 pragma Inline
(Is_Greater_Key_Node
);
769 --------------------------
770 -- Local Instantiations --
771 --------------------------
774 new Red_Black_Trees
.Generic_Keys
775 (Tree_Operations
=> Tree_Operations
,
776 Key_Type
=> Key_Type
,
777 Is_Less_Key_Node
=> Is_Less_Key_Node
,
778 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
784 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
is
785 Node
: constant Node_Access
:= Key_Keys
.Ceiling
(Container
.Tree
, Key
);
792 return Cursor
'(Container'Unrestricted_Access, Node);
799 function Contains (Container : Set; Key : Key_Type) return Boolean is
801 return Find (Container, Key) /= No_Element;
808 procedure Delete (Container : in out Set; Key : Key_Type) is
809 Tree : Tree_Type renames Container.Tree;
810 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
811 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
816 raise Constraint_Error with "attempt to delete key not in set";
821 Node := Tree_Operations.Next (Node);
822 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
825 exit when Node = Done;
833 function Element (Container : Set; Key : Key_Type) return Element_Type is
834 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
838 raise Constraint_Error with "key not in set";
841 return Node.Element.all;
844 ---------------------
845 -- Equivalent_Keys --
846 ---------------------
848 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
863 procedure Exclude (Container : in out Set; Key : Key_Type) is
864 Tree : Tree_Type renames Container.Tree;
865 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
866 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
870 while Node /= Done loop
872 Node := Tree_Operations.Next (Node);
873 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
882 function Find (Container : Set; Key : Key_Type) return Cursor is
883 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
890 return Cursor'(Container
'Unrestricted_Access, Node
);
897 function Floor
(Container
: Set
; Key
: Key_Type
) return Cursor
is
898 Node
: constant Node_Access
:= Key_Keys
.Floor
(Container
.Tree
, Key
);
905 return Cursor
'(Container'Unrestricted_Access, Node);
908 -------------------------
909 -- Is_Greater_Key_Node --
910 -------------------------
912 function Is_Greater_Key_Node
914 Right : Node_Access) return Boolean
917 return Key (Right.Element.all) < Left;
918 end Is_Greater_Key_Node;
920 ----------------------
921 -- Is_Less_Key_Node --
922 ----------------------
924 function Is_Less_Key_Node
926 Right : Node_Access) return Boolean
929 return Left < Key (Right.Element.all);
930 end Is_Less_Key_Node;
939 Process : not null access procedure (Position : Cursor))
941 procedure Process_Node (Node : Node_Access);
942 pragma Inline (Process_Node);
944 procedure Local_Iterate is
945 new Key_Keys.Generic_Iteration (Process_Node);
951 procedure Process_Node (Node : Node_Access) is
953 Process (Cursor'(Container
'Unrestricted_Access, Node
));
956 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
957 Busy
: With_Busy
(T
.TC
'Unrestricted_Access);
959 -- Start of processing for Iterate
962 Local_Iterate
(T
, Key
);
969 function Key
(Position
: Cursor
) return Key_Type
is
971 if Position
.Node
= null then
972 raise Constraint_Error
with
973 "Position cursor equals No_Element";
976 if Position
.Node
.Element
= null then
977 raise Program_Error
with
978 "Position cursor is bad";
981 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
982 "bad cursor in Key");
984 return Key
(Position
.Node
.Element
.all);
987 ---------------------
988 -- Reverse_Iterate --
989 ---------------------
991 procedure Reverse_Iterate
994 Process
: not null access procedure (Position
: Cursor
))
996 procedure Process_Node
(Node
: Node_Access
);
997 pragma Inline
(Process_Node
);
1003 procedure Local_Reverse_Iterate
is
1004 new Key_Keys
.Generic_Reverse_Iteration
(Process_Node
);
1010 procedure Process_Node
(Node
: Node_Access
) is
1012 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1015 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1016 Busy : With_Busy (T.TC'Unrestricted_Access);
1018 -- Start of processing for Reverse_Iterate
1021 Local_Reverse_Iterate (T, Key);
1022 end Reverse_Iterate;
1024 --------------------
1025 -- Update_Element --
1026 --------------------
1028 procedure Update_Element
1029 (Container : in out Set;
1031 Process : not null access procedure (Element : in out Element_Type))
1033 Tree : Tree_Type renames Container.Tree;
1034 Node : constant Node_Access := Position.Node;
1038 raise Constraint_Error with "Position cursor equals No_Element";
1041 if Node.Element = null then
1042 raise Program_Error with "Position cursor is bad";
1045 if Position.Container /= Container'Unrestricted_Access then
1046 raise Program_Error with "Position cursor designates wrong set";
1049 pragma Assert (Vet (Tree, Node),
1050 "bad cursor in Update_Element");
1053 E : Element_Type renames Node.Element.all;
1054 K : constant Key_Type := Key (E);
1055 Lock : With_Lock (Tree.TC'Unrestricted_Access);
1059 if Equivalent_Keys (Left => K, Right => Key (E)) then
1064 -- Delete_Node checks busy-bit
1066 Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
1068 Insert_New_Item : declare
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
1084 Node.Color := Red_Black_Trees.Red;
1085 Node.Parent := null;
1092 Result : Node_Access;
1094 -- Start of processing for Insert_New_Item
1097 Unconditional_Insert
1099 Key => Node.Element.all,
1102 pragma Assert (Result = Node);
1103 end Insert_New_Item;
1112 function Has_Element (Position : Cursor) return Boolean is
1114 return Position /= No_Element;
1121 procedure Insert (Container : in out Set; New_Item : Element_Type) is
1124 Insert (Container, New_Item, Position);
1128 (Container : in out Set;
1129 New_Item : Element_Type;
1130 Position : out Cursor)
1133 Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
1134 Position.Container := Container'Unrestricted_Access;
1137 ----------------------
1138 -- Insert_Sans_Hint --
1139 ----------------------
1141 procedure Insert_Sans_Hint
1142 (Tree : in out Tree_Type;
1143 New_Item : Element_Type;
1144 Node : out Node_Access)
1146 function New_Node return Node_Access;
1147 pragma Inline (New_Node);
1149 procedure Insert_Post is
1150 new Element_Keys.Generic_Insert_Post (New_Node);
1152 procedure Unconditional_Insert is
1153 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1159 function New_Node return Node_Access is
1160 -- The element allocator may need an accessibility check in the case
1161 -- the actual type is class-wide or has access discriminants (see
1162 -- RM 4.8(10.1) and AI12-0035).
1164 pragma Unsuppress (Accessibility_Check);
1166 Element : Element_Access := new Element_Type'(New_Item
);
1169 return new Node_Type
'(Parent => null,
1172 Color => Red_Black_Trees.Red,
1173 Element => Element);
1177 Free_Element (Element);
1181 -- Start of processing for Insert_Sans_Hint
1184 Unconditional_Insert (Tree, New_Item, Node);
1185 end Insert_Sans_Hint;
1187 ----------------------
1188 -- Insert_With_Hint --
1189 ----------------------
1191 procedure Insert_With_Hint
1192 (Dst_Tree : in out Tree_Type;
1193 Dst_Hint : Node_Access;
1194 Src_Node : Node_Access;
1195 Dst_Node : out Node_Access)
1197 function New_Node return Node_Access;
1198 pragma Inline (New_Node);
1200 procedure Insert_Post is
1201 new Element_Keys.Generic_Insert_Post (New_Node);
1203 procedure Insert_Sans_Hint is
1204 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1206 procedure Local_Insert_With_Hint is
1207 new Element_Keys.Generic_Unconditional_Insert_With_Hint
1215 function New_Node return Node_Access is
1216 X : Element_Access := new Element_Type'(Src_Node
.Element
.all);
1219 return new Node_Type
'(Parent => null,
1231 -- Start of processing for Insert_With_Hint
1234 Local_Insert_With_Hint
1237 Src_Node.Element.all,
1239 end Insert_With_Hint;
1245 procedure Intersection (Target : in out Set; Source : Set) is
1247 Set_Ops.Intersection (Target.Tree, Source.Tree);
1250 function Intersection (Left, Right : Set) return Set is
1251 Tree : constant Tree_Type :=
1252 Set_Ops.Intersection (Left.Tree, Right.Tree);
1254 return Set'(Controlled
with Tree
);
1261 function Is_Empty
(Container
: Set
) return Boolean is
1263 return Container
.Tree
.Length
= 0;
1266 ------------------------
1267 -- Is_Equal_Node_Node --
1268 ------------------------
1270 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean is
1272 return L
.Element
.all = R
.Element
.all;
1273 end Is_Equal_Node_Node
;
1275 -----------------------------
1276 -- Is_Greater_Element_Node --
1277 -----------------------------
1279 function Is_Greater_Element_Node
1280 (Left
: Element_Type
;
1281 Right
: Node_Access
) return Boolean
1284 -- e > node same as node < e
1286 return Right
.Element
.all < Left
;
1287 end Is_Greater_Element_Node
;
1289 --------------------------
1290 -- Is_Less_Element_Node --
1291 --------------------------
1293 function Is_Less_Element_Node
1294 (Left
: Element_Type
;
1295 Right
: Node_Access
) return Boolean
1298 return Left
< Right
.Element
.all;
1299 end Is_Less_Element_Node
;
1301 -----------------------
1302 -- Is_Less_Node_Node --
1303 -----------------------
1305 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean is
1307 return L
.Element
.all < R
.Element
.all;
1308 end Is_Less_Node_Node
;
1314 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
1316 return Set_Ops
.Is_Subset
(Subset
=> Subset
.Tree
, Of_Set
=> Of_Set
.Tree
);
1325 Item
: Element_Type
;
1326 Process
: not null access procedure (Position
: Cursor
))
1328 procedure Process_Node
(Node
: Node_Access
);
1329 pragma Inline
(Process_Node
);
1331 procedure Local_Iterate
is
1332 new Element_Keys
.Generic_Iteration
(Process_Node
);
1338 procedure Process_Node
(Node
: Node_Access
) is
1340 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1343 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1344 Busy : With_Busy (T.TC'Unrestricted_Access);
1346 -- Start of processing for Iterate
1349 Local_Iterate (T, Item);
1354 Process : not null access procedure (Position : Cursor))
1356 procedure Process_Node (Node : Node_Access);
1357 pragma Inline (Process_Node);
1359 procedure Local_Iterate is
1360 new Tree_Operations.Generic_Iteration (Process_Node);
1366 procedure Process_Node (Node : Node_Access) is
1368 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1371 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
1372 Busy
: With_Busy
(T
.TC
'Unrestricted_Access);
1374 -- Start of processing for Iterate
1380 function Iterate
(Container
: Set
)
1381 return Set_Iterator_Interfaces
.Reversible_Iterator
'Class
1383 S
: constant Set_Access
:= Container
'Unrestricted_Access;
1385 -- The value of the Node component influences the behavior of the First
1386 -- and Last selector functions of the iterator object. When the Node
1387 -- component is null (as is the case here), this means the iterator
1388 -- object was constructed without a start expression. This is a complete
1389 -- iterator, meaning that the iteration starts from the (logical)
1390 -- beginning of the sequence of items.
1392 -- Note: For a forward iterator, Container.First is the beginning, and
1393 -- for a reverse iterator, Container.Last is the beginning.
1395 return It
: constant Iterator
:= (Limited_Controlled
with S
, null) do
1400 function Iterate
(Container
: Set
; Start
: Cursor
)
1401 return Set_Iterator_Interfaces
.Reversible_Iterator
'Class
1403 S
: constant Set_Access
:= Container
'Unrestricted_Access;
1405 -- It was formerly the case that when Start = No_Element, the partial
1406 -- iterator was defined to behave the same as for a complete iterator,
1407 -- and iterate over the entire sequence of items. However, those
1408 -- semantics were unintuitive and arguably error-prone (it is too easy
1409 -- to accidentally create an endless loop), and so they were changed,
1410 -- per the ARG meeting in Denver on 2011/11. However, there was no
1411 -- consensus about what positive meaning this corner case should have,
1412 -- and so it was decided to simply raise an exception. This does imply,
1413 -- however, that it is not possible to use a partial iterator to specify
1414 -- an empty sequence of items.
1416 if Start
= No_Element
then
1417 raise Constraint_Error
with
1418 "Start position for iterator equals No_Element";
1421 if Start
.Container
/= Container
'Unrestricted_Access then
1422 raise Program_Error
with
1423 "Start cursor of Iterate designates wrong set";
1426 pragma Assert
(Vet
(Container
.Tree
, Start
.Node
),
1427 "Start cursor of Iterate is bad");
1429 -- The value of the Node component influences the behavior of the First
1430 -- and Last selector functions of the iterator object. When the Node
1431 -- component is non-null (as is the case here), it means that this is a
1432 -- partial iteration, over a subset of the complete sequence of
1433 -- items. The iterator object was constructed with a start expression,
1434 -- indicating the position from which the iteration begins. Note that
1435 -- the start position has the same value irrespective of whether this is
1436 -- a forward or reverse iteration.
1438 return It
: constant Iterator
:=
1439 (Limited_Controlled
with S
, Start
.Node
)
1449 function Last
(Container
: Set
) return Cursor
is
1451 if Container
.Tree
.Last
= null then
1455 return Cursor
'(Container'Unrestricted_Access, Container.Tree.Last);
1458 function Last (Object : Iterator) return Cursor is
1460 -- The value of the iterator object's Node component influences the
1461 -- behavior of the Last (and First) selector function.
1463 -- When the Node component is null, this means the iterator object was
1464 -- constructed without a start expression, in which case the (reverse)
1465 -- iteration starts from the (logical) beginning of the entire sequence
1466 -- (corresponding to Container.Last, for a reverse iterator).
1468 -- Otherwise, this is iteration over a partial sequence of items. When
1469 -- the Node component is non-null, the iterator object was constructed
1470 -- with a start expression, that specifies the position from which the
1471 -- (reverse) partial iteration begins.
1473 if Object.Node = null then
1474 return Object.Container.Last;
1476 return Cursor'(Object
.Container
, Object
.Node
);
1484 function Last_Element
(Container
: Set
) return Element_Type
is
1486 if Container
.Tree
.Last
= null then
1487 raise Constraint_Error
with "set is empty";
1490 pragma Assert
(Container
.Tree
.Last
.Element
/= null);
1491 return Container
.Tree
.Last
.Element
.all;
1498 function Left
(Node
: Node_Access
) return Node_Access
is
1507 function Length
(Container
: Set
) return Count_Type
is
1509 return Container
.Tree
.Length
;
1517 new Tree_Operations
.Generic_Move
(Clear
);
1519 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1521 Move
(Target
=> Target
.Tree
, Source
=> Source
.Tree
);
1528 function Next
(Position
: Cursor
) return Cursor
is
1530 if Position
= No_Element
then
1534 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1535 "bad cursor in Next");
1538 Node
: constant Node_Access
:=
1539 Tree_Operations
.Next
(Position
.Node
);
1546 return Cursor
'(Position.Container, Node);
1550 procedure Next (Position : in out Cursor) is
1552 Position := Next (Position);
1555 function Next (Object : Iterator; Position : Cursor) return Cursor is
1557 if Position.Container = null then
1561 if Position.Container /= Object.Container then
1562 raise Program_Error with
1563 "Position cursor of Next designates wrong set";
1566 return Next (Position);
1573 function Overlap (Left, Right : Set) return Boolean is
1575 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1582 function Parent (Node : Node_Access) return Node_Access is
1591 function Previous (Position : Cursor) return Cursor is
1593 if Position = No_Element then
1597 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1598 "bad cursor in Previous");
1601 Node : constant Node_Access :=
1602 Tree_Operations.Previous (Position.Node);
1609 return Cursor'(Position
.Container
, Node
);
1613 procedure Previous
(Position
: in out Cursor
) is
1615 Position
:= Previous
(Position
);
1618 function Previous
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
1620 if Position
.Container
= null then
1624 if Position
.Container
/= Object
.Container
then
1625 raise Program_Error
with
1626 "Position cursor of Previous designates wrong set";
1629 return Previous
(Position
);
1636 procedure Query_Element
1638 Process
: not null access procedure (Element
: Element_Type
))
1641 if Position
.Node
= null then
1642 raise Constraint_Error
with "Position cursor equals No_Element";
1645 if Position
.Node
.Element
= null then
1646 raise Program_Error
with "Position cursor is bad";
1649 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1650 "bad cursor in Query_Element");
1653 T
: Tree_Type
renames Position
.Container
.Tree
;
1654 Lock
: With_Lock
(T
.TC
'Unrestricted_Access);
1656 Process
(Position
.Node
.Element
.all);
1665 (S
: in out Ada
.Strings
.Text_Buffers
.Root_Buffer_Type
'Class; V
: Set
)
1667 First_Time
: Boolean := True;
1668 use System
.Put_Images
;
1674 First_Time
:= False;
1676 Simple_Array_Between
(S
);
1679 Element_Type
'Put_Image (S
, X
);
1690 (Stream
: not null access Root_Stream_Type
'Class;
1691 Container
: out Set
)
1694 (Stream
: not null access Root_Stream_Type
'Class) return Node_Access
;
1695 pragma Inline
(Read_Node
);
1698 new Tree_Operations
.Generic_Read
(Clear
, Read_Node
);
1705 (Stream
: not null access Root_Stream_Type
'Class) return Node_Access
1707 Node
: Node_Access
:= new Node_Type
;
1709 Node
.Element
:= new Element_Type
'(Element_Type'Input (Stream));
1713 Free (Node); -- Note that Free deallocates elem too
1717 -- Start of processing for Read
1720 Read (Stream, Container.Tree);
1724 (Stream : not null access Root_Stream_Type'Class;
1728 raise Program_Error with "attempt to stream set cursor";
1732 (Stream : not null access Root_Stream_Type'Class;
1733 Item : out Constant_Reference_Type)
1736 raise Program_Error with "attempt to stream reference";
1739 ---------------------
1740 -- Replace_Element --
1741 ---------------------
1743 procedure Replace_Element
1744 (Tree : in out Tree_Type;
1746 Item : Element_Type)
1749 if Item < Node.Element.all
1750 or else Node.Element.all < Item
1757 X : Element_Access := Node.Element;
1759 -- The element allocator may need an accessibility check in the
1760 -- case the actual type is class-wide or has access discriminants
1761 -- (see RM 4.8(10.1) and AI12-0035).
1763 pragma Unsuppress (Accessibility_Check);
1766 Node.Element := new Element_Type'(Item
);
1773 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Node
); -- Checks busy-bit
1775 Insert_New_Item
: declare
1776 function New_Node
return Node_Access
;
1777 pragma Inline
(New_Node
);
1779 procedure Insert_Post
is
1780 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1782 procedure Unconditional_Insert
is
1783 new Element_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
1789 function New_Node
return Node_Access
is
1791 -- The element allocator may need an accessibility check in the
1792 -- case the actual type is class-wide or has access discriminants
1793 -- (see RM 4.8(10.1) and AI12-0035).
1795 pragma Unsuppress
(Accessibility_Check
);
1798 Node
.Element
:= new Element_Type
'(Item); -- OK if fails
1799 Node.Color := Red_Black_Trees.Red;
1800 Node.Parent := null;
1807 Result : Node_Access;
1809 X : Element_Access := Node.Element;
1811 -- Start of processing for Insert_New_Item
1814 Unconditional_Insert
1818 pragma Assert (Result = Node);
1820 Free_Element (X); -- OK if fails
1821 end Insert_New_Item;
1822 end Replace_Element;
1824 procedure Replace_Element
1825 (Container : in out Set;
1827 New_Item : Element_Type)
1830 if Position.Node = null then
1831 raise Constraint_Error with "Position cursor equals No_Element";
1834 if Position.Node.Element = null then
1835 raise Program_Error with "Position cursor is bad";
1838 if Position.Container /= Container'Unrestricted_Access then
1839 raise Program_Error with "Position cursor designates wrong set";
1842 pragma Assert (Vet (Container.Tree, Position.Node),
1843 "bad cursor in Replace_Element");
1845 Replace_Element (Container.Tree, Position.Node, New_Item);
1846 end Replace_Element;
1848 ---------------------
1849 -- Reverse_Iterate --
1850 ---------------------
1852 procedure Reverse_Iterate
1854 Item : Element_Type;
1855 Process : not null access procedure (Position : Cursor))
1857 procedure Process_Node (Node : Node_Access);
1858 pragma Inline (Process_Node);
1860 procedure Local_Reverse_Iterate is
1861 new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1867 procedure Process_Node (Node : Node_Access) is
1869 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1872 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
1873 Busy
: With_Busy
(T
.TC
'Unrestricted_Access);
1875 -- Start of processing for Reverse_Iterate
1878 Local_Reverse_Iterate
(T
, Item
);
1879 end Reverse_Iterate
;
1881 procedure Reverse_Iterate
1883 Process
: not null access procedure (Position
: Cursor
))
1885 procedure Process_Node
(Node
: Node_Access
);
1886 pragma Inline
(Process_Node
);
1888 procedure Local_Reverse_Iterate
is
1889 new Tree_Operations
.Generic_Reverse_Iteration
(Process_Node
);
1895 procedure Process_Node
(Node
: Node_Access
) is
1897 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1900 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1901 Busy : With_Busy (T.TC'Unrestricted_Access);
1903 -- Start of processing for Reverse_Iterate
1906 Local_Reverse_Iterate (T);
1907 end Reverse_Iterate;
1913 function Right (Node : Node_Access) return Node_Access is
1922 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1924 Node.Color := Color;
1931 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1940 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1942 Node.Parent := Parent;
1949 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1951 Node.Right := Right;
1954 --------------------------
1955 -- Symmetric_Difference --
1956 --------------------------
1958 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1960 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1961 end Symmetric_Difference;
1963 function Symmetric_Difference (Left, Right : Set) return Set is
1964 Tree : constant Tree_Type :=
1965 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1967 return Set'(Controlled
with Tree
);
1968 end Symmetric_Difference
;
1974 function To_Set
(New_Item
: Element_Type
) return Set
is
1978 Insert_Sans_Hint
(Tree
, New_Item
, Node
);
1979 return Set
'(Controlled with Tree);
1986 procedure Union (Target : in out Set; Source : Set) is
1988 Set_Ops.Union (Target.Tree, Source.Tree);
1991 function Union (Left, Right : Set) return Set is
1992 Tree : constant Tree_Type :=
1993 Set_Ops.Union (Left.Tree, Right.Tree);
1995 return Set'(Controlled
with Tree
);
2003 (Stream
: not null access Root_Stream_Type
'Class;
2006 procedure Write_Node
2007 (Stream
: not null access Root_Stream_Type
'Class;
2008 Node
: Node_Access
);
2009 pragma Inline
(Write_Node
);
2012 new Tree_Operations
.Generic_Write
(Write_Node
);
2018 procedure Write_Node
2019 (Stream
: not null access Root_Stream_Type
'Class;
2023 Element_Type
'Output (Stream
, Node
.Element
.all);
2026 -- Start of processing for Write
2029 Write
(Stream
, Container
.Tree
);
2033 (Stream
: not null access Root_Stream_Type
'Class;
2037 raise Program_Error
with "attempt to stream set cursor";
2041 (Stream
: not null access Root_Stream_Type
'Class;
2042 Item
: Constant_Reference_Type
)
2045 raise Program_Error
with "attempt to stream reference";
2047 end Ada
.Containers
.Indefinite_Ordered_Multisets
;