1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS --
9 -- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.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
.Indefinite_Ordered_Multisets
is
45 pragma Annotate
(CodePeer
, Skip_Analysis
);
47 -----------------------------
48 -- Node Access Subprograms --
49 -----------------------------
51 -- These subprograms provide a functional interface to access fields
52 -- of a node, and a procedural interface for modifying these values.
54 function Color
(Node
: Node_Access
) return Color_Type
;
55 pragma Inline
(Color
);
57 function Left
(Node
: Node_Access
) return Node_Access
;
60 function Parent
(Node
: Node_Access
) return Node_Access
;
61 pragma Inline
(Parent
);
63 function Right
(Node
: Node_Access
) return Node_Access
;
64 pragma Inline
(Right
);
66 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
67 pragma Inline
(Set_Parent
);
69 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
70 pragma Inline
(Set_Left
);
72 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
73 pragma Inline
(Set_Right
);
75 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
76 pragma Inline
(Set_Color
);
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
83 pragma Inline
(Copy_Node
);
85 procedure Free
(X
: in out Node_Access
);
87 procedure Insert_Sans_Hint
88 (Tree
: in out Tree_Type
;
89 New_Item
: Element_Type
;
90 Node
: out Node_Access
);
92 procedure Insert_With_Hint
93 (Dst_Tree
: in out Tree_Type
;
94 Dst_Hint
: Node_Access
;
95 Src_Node
: Node_Access
;
96 Dst_Node
: out Node_Access
);
98 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean;
99 pragma Inline
(Is_Equal_Node_Node
);
101 function Is_Greater_Element_Node
102 (Left
: Element_Type
;
103 Right
: Node_Access
) return Boolean;
104 pragma Inline
(Is_Greater_Element_Node
);
106 function Is_Less_Element_Node
107 (Left
: Element_Type
;
108 Right
: Node_Access
) return Boolean;
109 pragma Inline
(Is_Less_Element_Node
);
111 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean;
112 pragma Inline
(Is_Less_Node_Node
);
114 procedure Replace_Element
115 (Tree
: in out Tree_Type
;
117 Item
: Element_Type
);
119 --------------------------
120 -- Local Instantiations --
121 --------------------------
123 package Tree_Operations
is
124 new Red_Black_Trees
.Generic_Operations
(Tree_Types
);
126 procedure Delete_Tree
is
127 new Tree_Operations
.Generic_Delete_Tree
(Free
);
129 function Copy_Tree
is
130 new Tree_Operations
.Generic_Copy_Tree
(Copy_Node
, Delete_Tree
);
134 procedure Free_Element
is
135 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
138 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
141 new Generic_Set_Operations
142 (Tree_Operations
=> Tree_Operations
,
143 Insert_With_Hint
=> Insert_With_Hint
,
144 Copy_Tree
=> Copy_Tree
,
145 Delete_Tree
=> Delete_Tree
,
146 Is_Less
=> Is_Less_Node_Node
,
149 package Element_Keys
is
150 new Red_Black_Trees
.Generic_Keys
151 (Tree_Operations
=> Tree_Operations
,
152 Key_Type
=> Element_Type
,
153 Is_Less_Key_Node
=> Is_Less_Element_Node
,
154 Is_Greater_Key_Node
=> Is_Greater_Element_Node
);
160 function "<" (Left
, Right
: Cursor
) return Boolean is
162 if Left
.Node
= null then
163 raise Constraint_Error
with "Left cursor equals No_Element";
166 if Right
.Node
= null then
167 raise Constraint_Error
with "Right cursor equals No_Element";
170 if Left
.Node
.Element
= null then
171 raise Program_Error
with "Left cursor is bad";
174 if Right
.Node
.Element
= null then
175 raise Program_Error
with "Right cursor is bad";
178 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
179 "bad Left cursor in ""<""");
181 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
182 "bad Right cursor in ""<""");
184 return Left
.Node
.Element
.all < Right
.Node
.Element
.all;
187 function "<" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
189 if Left
.Node
= null then
190 raise Constraint_Error
with "Left cursor equals No_Element";
193 if Left
.Node
.Element
= null then
194 raise Program_Error
with "Left cursor is bad";
197 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
198 "bad Left cursor in ""<""");
200 return Left
.Node
.Element
.all < Right
;
203 function "<" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
205 if Right
.Node
= null then
206 raise Constraint_Error
with "Right cursor equals No_Element";
209 if Right
.Node
.Element
= null then
210 raise Program_Error
with "Right cursor is bad";
213 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
214 "bad Right cursor in ""<""");
216 return Left
< Right
.Node
.Element
.all;
223 function "=" (Left
, Right
: Set
) return Boolean is
225 return Is_Equal
(Left
.Tree
, Right
.Tree
);
232 function ">" (Left
, Right
: Cursor
) return Boolean is
234 if Left
.Node
= null then
235 raise Constraint_Error
with "Left cursor equals No_Element";
238 if Right
.Node
= null then
239 raise Constraint_Error
with "Right cursor equals No_Element";
242 if Left
.Node
.Element
= null then
243 raise Program_Error
with "Left cursor is bad";
246 if Right
.Node
.Element
= null then
247 raise Program_Error
with "Right cursor is bad";
250 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
251 "bad Left cursor in "">""");
253 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
254 "bad Right cursor in "">""");
256 -- L > R same as R < L
258 return Right
.Node
.Element
.all < Left
.Node
.Element
.all;
261 function ">" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
263 if Left
.Node
= null then
264 raise Constraint_Error
with "Left cursor equals No_Element";
267 if Left
.Node
.Element
= null then
268 raise Program_Error
with "Left cursor is bad";
271 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
272 "bad Left cursor in "">""");
274 return Right
< Left
.Node
.Element
.all;
277 function ">" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
279 if Right
.Node
= null then
280 raise Constraint_Error
with "Right cursor equals No_Element";
283 if Right
.Node
.Element
= null then
284 raise Program_Error
with "Right cursor is bad";
287 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
288 "bad Right cursor in "">""");
290 return Right
.Node
.Element
.all < Left
;
298 new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
300 procedure Adjust
(Container
: in out Set
) is
302 Adjust
(Container
.Tree
);
309 procedure Assign
(Target
: in out Set
; Source
: Set
) is
311 if Target
'Address = Source
'Address then
316 Target
.Union
(Source
);
323 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
is
324 Node
: constant Node_Access
:=
325 Element_Keys
.Ceiling
(Container
.Tree
, Item
);
332 return Cursor
'(Container'Unrestricted_Access, Node);
340 new Tree_Operations.Generic_Clear (Delete_Tree);
342 procedure Clear (Container : in out Set) is
344 Clear (Container.Tree);
351 function Color (Node : Node_Access) return Color_Type is
360 function Contains (Container : Set; Item : Element_Type) return Boolean is
362 return Find (Container, Item) /= No_Element;
369 function Copy (Source : Set) return Set is
371 return Target : Set do
372 Target.Assign (Source);
380 function Copy_Node (Source : Node_Access) return Node_Access is
381 X : Element_Access := new Element_Type'(Source
.Element
.all);
384 return new Node_Type
'(Parent => null,
387 Color => Source.Color,
400 procedure Delete (Container : in out Set; Item : Element_Type) is
401 Tree : Tree_Type renames Container.Tree;
402 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
403 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
408 raise Constraint_Error with "attempt to delete element not in set";
413 Node := Tree_Operations.Next (Node);
414 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
417 exit when Node = Done;
421 procedure Delete (Container : in out Set; Position : in out Cursor) is
423 if Position.Node = null then
424 raise Constraint_Error with "Position cursor equals No_Element";
427 if Position.Node.Element = null then
428 raise Program_Error with "Position cursor is bad";
431 if Position.Container /= Container'Unrestricted_Access then
432 raise Program_Error with "Position cursor designates wrong set";
435 pragma Assert (Vet (Container.Tree, Position.Node),
436 "bad cursor in Delete");
438 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
439 Free (Position.Node);
441 Position.Container := null;
448 procedure Delete_First (Container : in out Set) is
449 Tree : Tree_Type renames Container.Tree;
450 X : Node_Access := Tree.First;
457 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
465 procedure Delete_Last (Container : in out Set) is
466 Tree : Tree_Type renames Container.Tree;
467 X : Node_Access := Tree.Last;
474 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
482 procedure Difference (Target : in out Set; Source : Set) is
484 Set_Ops.Difference (Target.Tree, Source.Tree);
487 function Difference (Left, Right : Set) return Set is
488 Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree);
490 return Set'(Controlled
with Tree
);
497 function Element
(Position
: Cursor
) return Element_Type
is
499 if Position
.Node
= null then
500 raise Constraint_Error
with "Position cursor equals No_Element";
503 if Position
.Node
.Element
= null then
504 raise Program_Error
with "Position cursor is bad";
507 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
508 "bad cursor in Element");
510 return Position
.Node
.Element
.all;
513 -------------------------
514 -- Equivalent_Elements --
515 -------------------------
517 function Equivalent_Elements
(Left
, Right
: Element_Type
) return Boolean is
526 end Equivalent_Elements
;
528 ---------------------
529 -- Equivalent_Sets --
530 ---------------------
532 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
534 function Is_Equivalent_Node_Node
(L
, R
: Node_Access
) return Boolean;
535 pragma Inline
(Is_Equivalent_Node_Node
);
537 function Is_Equivalent
is
538 new Tree_Operations
.Generic_Equal
(Is_Equivalent_Node_Node
);
540 -----------------------------
541 -- Is_Equivalent_Node_Node --
542 -----------------------------
544 function Is_Equivalent_Node_Node
(L
, R
: Node_Access
) return Boolean is
546 if L
.Element
.all < R
.Element
.all then
548 elsif R
.Element
.all < L
.Element
.all then
553 end Is_Equivalent_Node_Node
;
555 -- Start of processing for Equivalent_Sets
558 return Is_Equivalent
(Left
.Tree
, Right
.Tree
);
565 procedure Exclude
(Container
: in out Set
; Item
: Element_Type
) is
566 Tree
: Tree_Type
renames Container
.Tree
;
567 Node
: Node_Access
:= Element_Keys
.Ceiling
(Tree
, Item
);
568 Done
: constant Node_Access
:= Element_Keys
.Upper_Bound
(Tree
, Item
);
572 while Node
/= Done
loop
574 Node
:= Tree_Operations
.Next
(Node
);
575 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
584 function Find
(Container
: Set
; Item
: Element_Type
) return Cursor
is
585 Node
: constant Node_Access
:= Element_Keys
.Find
(Container
.Tree
, Item
);
592 return Cursor
'(Container'Unrestricted_Access, Node);
599 procedure Finalize (Object : in out Iterator) is
600 B : Natural renames Object.Container.Tree.Busy;
601 pragma Assert (B > 0);
610 function First (Container : Set) return Cursor is
612 if Container.Tree.First = null then
616 return Cursor'(Container
'Unrestricted_Access, Container
.Tree
.First
);
619 function First
(Object
: Iterator
) return Cursor
is
621 -- The value of the iterator object's Node component influences the
622 -- behavior of the First (and Last) selector function.
624 -- When the Node component is null, this means the iterator object was
625 -- constructed without a start expression, in which case the (forward)
626 -- iteration starts from the (logical) beginning of the entire sequence
627 -- of items (corresponding to Container.First, for a forward iterator).
629 -- Otherwise, this is iteration over a partial sequence of items. When
630 -- the Node component is non-null, the iterator object was constructed
631 -- with a start expression, that specifies the position from which the
632 -- (forward) partial iteration begins.
634 if Object
.Node
= null then
635 return Object
.Container
.First
;
637 return Cursor
'(Object.Container, Object.Node);
645 function First_Element (Container : Set) return Element_Type is
647 if Container.Tree.First = null then
648 raise Constraint_Error with "set is empty";
651 pragma Assert (Container.Tree.First.Element /= null);
652 return Container.Tree.First.Element.all;
659 function Floor (Container : Set; Item : Element_Type) return Cursor is
660 Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item);
667 return Cursor'(Container
'Unrestricted_Access, Node
);
674 procedure Free
(X
: in out Node_Access
) is
675 procedure Deallocate
is
676 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
688 Free_Element
(X
.Element
);
703 package body Generic_Keys
is
705 -----------------------
706 -- Local Subprograms --
707 -----------------------
709 function Is_Less_Key_Node
711 Right
: Node_Access
) return Boolean;
712 pragma Inline
(Is_Less_Key_Node
);
714 function Is_Greater_Key_Node
716 Right
: Node_Access
) return Boolean;
717 pragma Inline
(Is_Greater_Key_Node
);
719 --------------------------
720 -- Local Instantiations --
721 --------------------------
724 new Red_Black_Trees
.Generic_Keys
725 (Tree_Operations
=> Tree_Operations
,
726 Key_Type
=> Key_Type
,
727 Is_Less_Key_Node
=> Is_Less_Key_Node
,
728 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
734 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
is
735 Node
: constant Node_Access
:= Key_Keys
.Ceiling
(Container
.Tree
, Key
);
742 return Cursor
'(Container'Unrestricted_Access, Node);
749 function Contains (Container : Set; Key : Key_Type) return Boolean is
751 return Find (Container, Key) /= No_Element;
758 procedure Delete (Container : in out Set; Key : Key_Type) is
759 Tree : Tree_Type renames Container.Tree;
760 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
761 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
766 raise Constraint_Error with "attempt to delete key not in set";
771 Node := Tree_Operations.Next (Node);
772 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
775 exit when Node = Done;
783 function Element (Container : Set; Key : Key_Type) return Element_Type is
784 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
788 raise Constraint_Error with "key not in set";
791 return Node.Element.all;
794 ---------------------
795 -- Equivalent_Keys --
796 ---------------------
798 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
813 procedure Exclude (Container : in out Set; Key : Key_Type) is
814 Tree : Tree_Type renames Container.Tree;
815 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
816 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
820 while Node /= Done loop
822 Node := Tree_Operations.Next (Node);
823 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
832 function Find (Container : Set; Key : Key_Type) return Cursor is
833 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
840 return Cursor'(Container
'Unrestricted_Access, Node
);
847 function Floor
(Container
: Set
; Key
: Key_Type
) return Cursor
is
848 Node
: constant Node_Access
:= Key_Keys
.Floor
(Container
.Tree
, Key
);
855 return Cursor
'(Container'Unrestricted_Access, Node);
858 -------------------------
859 -- Is_Greater_Key_Node --
860 -------------------------
862 function Is_Greater_Key_Node
864 Right : Node_Access) return Boolean
867 return Key (Right.Element.all) < Left;
868 end Is_Greater_Key_Node;
870 ----------------------
871 -- Is_Less_Key_Node --
872 ----------------------
874 function Is_Less_Key_Node
876 Right : Node_Access) return Boolean
879 return Left < Key (Right.Element.all);
880 end Is_Less_Key_Node;
889 Process : not null access procedure (Position : Cursor))
891 procedure Process_Node (Node : Node_Access);
892 pragma Inline (Process_Node);
894 procedure Local_Iterate is
895 new Key_Keys.Generic_Iteration (Process_Node);
901 procedure Process_Node (Node : Node_Access) is
903 Process (Cursor'(Container
'Unrestricted_Access, Node
));
906 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
907 B
: Natural renames T
.Busy
;
909 -- Start of processing for Iterate
915 Local_Iterate
(T
, Key
);
929 function Key
(Position
: Cursor
) return Key_Type
is
931 if Position
.Node
= null then
932 raise Constraint_Error
with
933 "Position cursor equals No_Element";
936 if Position
.Node
.Element
= null then
937 raise Program_Error
with
938 "Position cursor is bad";
941 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
942 "bad cursor in Key");
944 return Key
(Position
.Node
.Element
.all);
947 ---------------------
948 -- Reverse_Iterate --
949 ---------------------
951 procedure Reverse_Iterate
954 Process
: not null access procedure (Position
: Cursor
))
956 procedure Process_Node
(Node
: Node_Access
);
957 pragma Inline
(Process_Node
);
963 procedure Local_Reverse_Iterate
is
964 new Key_Keys
.Generic_Reverse_Iteration
(Process_Node
);
970 procedure Process_Node
(Node
: Node_Access
) is
972 Process
(Cursor
'(Container'Unrestricted_Access, Node));
975 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
976 B : Natural renames T.Busy;
978 -- Start of processing for Reverse_Iterate
984 Local_Reverse_Iterate (T, Key);
998 procedure Update_Element
999 (Container : in out Set;
1001 Process : not null access procedure (Element : in out Element_Type))
1003 Tree : Tree_Type renames Container.Tree;
1004 Node : constant Node_Access := Position.Node;
1008 raise Constraint_Error with "Position cursor equals No_Element";
1011 if Node.Element = null then
1012 raise Program_Error with "Position cursor is bad";
1015 if Position.Container /= Container'Unrestricted_Access then
1016 raise Program_Error with "Position cursor designates wrong set";
1019 pragma Assert (Vet (Tree, Node),
1020 "bad cursor in Update_Element");
1023 E : Element_Type renames Node.Element.all;
1024 K : constant Key_Type := Key (E);
1026 B : Natural renames Tree.Busy;
1027 L : Natural renames Tree.Lock;
1045 if Equivalent_Keys (Left => K, Right => Key (E)) then
1050 -- Delete_Node checks busy-bit
1052 Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
1054 Insert_New_Item : declare
1055 function New_Node return Node_Access;
1056 pragma Inline (New_Node);
1058 procedure Insert_Post is
1059 new Element_Keys.Generic_Insert_Post (New_Node);
1061 procedure Unconditional_Insert is
1062 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1068 function New_Node return Node_Access is
1070 Node.Color := Red_Black_Trees.Red;
1071 Node.Parent := null;
1078 Result : Node_Access;
1080 -- Start of processing for Insert_New_Item
1083 Unconditional_Insert
1085 Key => Node.Element.all,
1088 pragma Assert (Result = Node);
1089 end Insert_New_Item;
1098 function Has_Element (Position : Cursor) return Boolean is
1100 return Position /= No_Element;
1107 procedure Insert (Container : in out Set; New_Item : Element_Type) is
1109 pragma Unreferenced (Position);
1111 Insert (Container, New_Item, Position);
1115 (Container : in out Set;
1116 New_Item : Element_Type;
1117 Position : out Cursor)
1120 Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
1121 Position.Container := Container'Unrestricted_Access;
1124 ----------------------
1125 -- Insert_Sans_Hint --
1126 ----------------------
1128 procedure Insert_Sans_Hint
1129 (Tree : in out Tree_Type;
1130 New_Item : Element_Type;
1131 Node : out Node_Access)
1133 function New_Node return Node_Access;
1134 pragma Inline (New_Node);
1136 procedure Insert_Post is
1137 new Element_Keys.Generic_Insert_Post (New_Node);
1139 procedure Unconditional_Insert is
1140 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1146 function New_Node return Node_Access is
1147 -- The element allocator may need an accessibility check in the case
1148 -- the actual type is class-wide or has access discriminants (see
1149 -- RM 4.8(10.1) and AI12-0035).
1151 pragma Unsuppress (Accessibility_Check);
1153 Element : Element_Access := new Element_Type'(New_Item
);
1156 return new Node_Type
'(Parent => null,
1159 Color => Red_Black_Trees.Red,
1160 Element => Element);
1164 Free_Element (Element);
1168 -- Start of processing for Insert_Sans_Hint
1171 Unconditional_Insert (Tree, New_Item, Node);
1172 end Insert_Sans_Hint;
1174 ----------------------
1175 -- Insert_With_Hint --
1176 ----------------------
1178 procedure Insert_With_Hint
1179 (Dst_Tree : in out Tree_Type;
1180 Dst_Hint : Node_Access;
1181 Src_Node : Node_Access;
1182 Dst_Node : out Node_Access)
1184 function New_Node return Node_Access;
1185 pragma Inline (New_Node);
1187 procedure Insert_Post is
1188 new Element_Keys.Generic_Insert_Post (New_Node);
1190 procedure Insert_Sans_Hint is
1191 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1193 procedure Local_Insert_With_Hint is
1194 new Element_Keys.Generic_Unconditional_Insert_With_Hint
1202 function New_Node return Node_Access is
1203 X : Element_Access := new Element_Type'(Src_Node
.Element
.all);
1206 return new Node_Type
'(Parent => null,
1218 -- Start of processing for Insert_With_Hint
1221 Local_Insert_With_Hint
1224 Src_Node.Element.all,
1226 end Insert_With_Hint;
1232 procedure Intersection (Target : in out Set; Source : Set) is
1234 Set_Ops.Intersection (Target.Tree, Source.Tree);
1237 function Intersection (Left, Right : Set) return Set is
1238 Tree : constant Tree_Type :=
1239 Set_Ops.Intersection (Left.Tree, Right.Tree);
1241 return Set'(Controlled
with Tree
);
1248 function Is_Empty
(Container
: Set
) return Boolean is
1250 return Container
.Tree
.Length
= 0;
1253 ------------------------
1254 -- Is_Equal_Node_Node --
1255 ------------------------
1257 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean is
1259 return L
.Element
.all = R
.Element
.all;
1260 end Is_Equal_Node_Node
;
1262 -----------------------------
1263 -- Is_Greater_Element_Node --
1264 -----------------------------
1266 function Is_Greater_Element_Node
1267 (Left
: Element_Type
;
1268 Right
: Node_Access
) return Boolean
1271 -- e > node same as node < e
1273 return Right
.Element
.all < Left
;
1274 end Is_Greater_Element_Node
;
1276 --------------------------
1277 -- Is_Less_Element_Node --
1278 --------------------------
1280 function Is_Less_Element_Node
1281 (Left
: Element_Type
;
1282 Right
: Node_Access
) return Boolean
1285 return Left
< Right
.Element
.all;
1286 end Is_Less_Element_Node
;
1288 -----------------------
1289 -- Is_Less_Node_Node --
1290 -----------------------
1292 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean is
1294 return L
.Element
.all < R
.Element
.all;
1295 end Is_Less_Node_Node
;
1301 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
1303 return Set_Ops
.Is_Subset
(Subset
=> Subset
.Tree
, Of_Set
=> Of_Set
.Tree
);
1312 Item
: Element_Type
;
1313 Process
: not null access procedure (Position
: Cursor
))
1315 procedure Process_Node
(Node
: Node_Access
);
1316 pragma Inline
(Process_Node
);
1318 procedure Local_Iterate
is
1319 new Element_Keys
.Generic_Iteration
(Process_Node
);
1325 procedure Process_Node
(Node
: Node_Access
) is
1327 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1330 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1331 B : Natural renames T.Busy;
1333 -- Start of processing for Iterate
1339 Local_Iterate (T, Item);
1351 Process : not null access procedure (Position : Cursor))
1353 procedure Process_Node (Node : Node_Access);
1354 pragma Inline (Process_Node);
1356 procedure Local_Iterate is
1357 new Tree_Operations.Generic_Iteration (Process_Node);
1363 procedure Process_Node (Node : Node_Access) is
1365 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1368 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
1369 B
: Natural renames T
.Busy
;
1371 -- Start of processing for Iterate
1387 function Iterate
(Container
: Set
)
1388 return Set_Iterator_Interfaces
.Reversible_Iterator
'Class
1390 S
: constant Set_Access
:= Container
'Unrestricted_Access;
1391 B
: Natural renames S
.Tree
.Busy
;
1394 -- The value of the Node component influences the behavior of the First
1395 -- and Last selector functions of the iterator object. When the Node
1396 -- component is null (as is the case here), this means the iterator
1397 -- object was constructed without a start expression. This is a complete
1398 -- iterator, meaning that the iteration starts from the (logical)
1399 -- beginning of the sequence of items.
1401 -- Note: For a forward iterator, Container.First is the beginning, and
1402 -- for a reverse iterator, Container.Last is the beginning.
1404 return It
: constant Iterator
:= (Limited_Controlled
with S
, null) do
1409 function Iterate
(Container
: Set
; Start
: Cursor
)
1410 return Set_Iterator_Interfaces
.Reversible_Iterator
'Class
1412 S
: constant Set_Access
:= Container
'Unrestricted_Access;
1413 B
: Natural renames S
.Tree
.Busy
;
1416 -- It was formerly the case that when Start = No_Element, the partial
1417 -- iterator was defined to behave the same as for a complete iterator,
1418 -- and iterate over the entire sequence of items. However, those
1419 -- semantics were unintuitive and arguably error-prone (it is too easy
1420 -- to accidentally create an endless loop), and so they were changed,
1421 -- per the ARG meeting in Denver on 2011/11. However, there was no
1422 -- consensus about what positive meaning this corner case should have,
1423 -- and so it was decided to simply raise an exception. This does imply,
1424 -- however, that it is not possible to use a partial iterator to specify
1425 -- an empty sequence of items.
1427 if Start
= No_Element
then
1428 raise Constraint_Error
with
1429 "Start position for iterator equals No_Element";
1432 if Start
.Container
/= Container
'Unrestricted_Access then
1433 raise Program_Error
with
1434 "Start cursor of Iterate designates wrong set";
1437 pragma Assert
(Vet
(Container
.Tree
, Start
.Node
),
1438 "Start cursor of Iterate is bad");
1440 -- The value of the Node component influences the behavior of the First
1441 -- and Last selector functions of the iterator object. When the Node
1442 -- component is non-null (as is the case here), it means that this is a
1443 -- partial iteration, over a subset of the complete sequence of
1444 -- items. The iterator object was constructed with a start expression,
1445 -- indicating the position from which the iteration begins. Note that
1446 -- the start position has the same value irrespective of whether this is
1447 -- a forward or reverse iteration.
1449 return It
: constant Iterator
:=
1450 (Limited_Controlled
with S
, Start
.Node
)
1460 function Last
(Container
: Set
) return Cursor
is
1462 if Container
.Tree
.Last
= null then
1466 return Cursor
'(Container'Unrestricted_Access, Container.Tree.Last);
1469 function Last (Object : Iterator) return Cursor is
1471 -- The value of the iterator object's Node component influences the
1472 -- behavior of the Last (and First) selector function.
1474 -- When the Node component is null, this means the iterator object was
1475 -- constructed without a start expression, in which case the (reverse)
1476 -- iteration starts from the (logical) beginning of the entire sequence
1477 -- (corresponding to Container.Last, for a reverse iterator).
1479 -- Otherwise, this is iteration over a partial sequence of items. When
1480 -- the Node component is non-null, the iterator object was constructed
1481 -- with a start expression, that specifies the position from which the
1482 -- (reverse) partial iteration begins.
1484 if Object.Node = null then
1485 return Object.Container.Last;
1487 return Cursor'(Object
.Container
, Object
.Node
);
1495 function Last_Element
(Container
: Set
) return Element_Type
is
1497 if Container
.Tree
.Last
= null then
1498 raise Constraint_Error
with "set is empty";
1501 pragma Assert
(Container
.Tree
.Last
.Element
/= null);
1502 return Container
.Tree
.Last
.Element
.all;
1509 function Left
(Node
: Node_Access
) return Node_Access
is
1518 function Length
(Container
: Set
) return Count_Type
is
1520 return Container
.Tree
.Length
;
1528 new Tree_Operations
.Generic_Move
(Clear
);
1530 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1532 Move
(Target
=> Target
.Tree
, Source
=> Source
.Tree
);
1539 function Next
(Position
: Cursor
) return Cursor
is
1541 if Position
= No_Element
then
1545 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1546 "bad cursor in Next");
1549 Node
: constant Node_Access
:=
1550 Tree_Operations
.Next
(Position
.Node
);
1557 return Cursor
'(Position.Container, Node);
1561 procedure Next (Position : in out Cursor) is
1563 Position := Next (Position);
1566 function Next (Object : Iterator; Position : Cursor) return Cursor is
1568 if Position.Container = null then
1572 if Position.Container /= Object.Container then
1573 raise Program_Error with
1574 "Position cursor of Next designates wrong set";
1577 return Next (Position);
1584 function Overlap (Left, Right : Set) return Boolean is
1586 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1593 function Parent (Node : Node_Access) return Node_Access is
1602 function Previous (Position : Cursor) return Cursor is
1604 if Position = No_Element then
1608 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1609 "bad cursor in Previous");
1612 Node : constant Node_Access :=
1613 Tree_Operations.Previous (Position.Node);
1620 return Cursor'(Position
.Container
, Node
);
1624 procedure Previous
(Position
: in out Cursor
) is
1626 Position
:= Previous
(Position
);
1629 function Previous
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
1631 if Position
.Container
= null then
1635 if Position
.Container
/= Object
.Container
then
1636 raise Program_Error
with
1637 "Position cursor of Previous designates wrong set";
1640 return Previous
(Position
);
1647 procedure Query_Element
1649 Process
: not null access procedure (Element
: Element_Type
))
1652 if Position
.Node
= null then
1653 raise Constraint_Error
with "Position cursor equals No_Element";
1656 if Position
.Node
.Element
= null then
1657 raise Program_Error
with "Position cursor is bad";
1660 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1661 "bad cursor in Query_Element");
1664 T
: Tree_Type
renames Position
.Container
.Tree
;
1666 B
: Natural renames T
.Busy
;
1667 L
: Natural renames T
.Lock
;
1674 Process
(Position
.Node
.Element
.all);
1692 (Stream
: not null access Root_Stream_Type
'Class;
1693 Container
: out Set
)
1696 (Stream
: not null access Root_Stream_Type
'Class) return Node_Access
;
1697 pragma Inline
(Read_Node
);
1700 new Tree_Operations
.Generic_Read
(Clear
, Read_Node
);
1707 (Stream
: not null access Root_Stream_Type
'Class) return Node_Access
1709 Node
: Node_Access
:= new Node_Type
;
1711 Node
.Element
:= new Element_Type
'(Element_Type'Input (Stream));
1715 Free (Node); -- Note that Free deallocates elem too
1719 -- Start of processing for Read
1722 Read (Stream, Container.Tree);
1726 (Stream : not null access Root_Stream_Type'Class;
1730 raise Program_Error with "attempt to stream set cursor";
1733 ---------------------
1734 -- Replace_Element --
1735 ---------------------
1737 procedure Replace_Element
1738 (Tree : in out Tree_Type;
1740 Item : Element_Type)
1743 if Item < Node.Element.all
1744 or else Node.Element.all < Item
1748 if Tree.Lock > 0 then
1749 raise Program_Error with
1750 "attempt to tamper with elements (set is locked)";
1754 X : Element_Access := Node.Element;
1756 -- The element allocator may need an accessibility check in the
1757 -- case the actual type is class-wide or has access discriminants
1758 -- (see RM 4.8(10.1) and AI12-0035).
1760 pragma Unsuppress (Accessibility_Check);
1763 Node.Element := new Element_Type'(Item
);
1770 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Node
); -- Checks busy-bit
1772 Insert_New_Item
: declare
1773 function New_Node
return Node_Access
;
1774 pragma Inline
(New_Node
);
1776 procedure Insert_Post
is
1777 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1779 procedure Unconditional_Insert
is
1780 new Element_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
1786 function New_Node
return Node_Access
is
1788 -- The element allocator may need an accessibility check in the
1789 -- case the actual type is class-wide or has access discriminants
1790 -- (see RM 4.8(10.1) and AI12-0035).
1792 pragma Unsuppress
(Accessibility_Check
);
1795 Node
.Element
:= new Element_Type
'(Item); -- OK if fails
1796 Node.Color := Red_Black_Trees.Red;
1797 Node.Parent := null;
1804 Result : Node_Access;
1806 X : Element_Access := Node.Element;
1808 -- Start of processing for Insert_New_Item
1811 Unconditional_Insert
1815 pragma Assert (Result = Node);
1817 Free_Element (X); -- OK if fails
1818 end Insert_New_Item;
1819 end Replace_Element;
1821 procedure Replace_Element
1822 (Container : in out Set;
1824 New_Item : Element_Type)
1827 if Position.Node = null then
1828 raise Constraint_Error with "Position cursor equals No_Element";
1831 if Position.Node.Element = null then
1832 raise Program_Error with "Position cursor is bad";
1835 if Position.Container /= Container'Unrestricted_Access then
1836 raise Program_Error with "Position cursor designates wrong set";
1839 pragma Assert (Vet (Container.Tree, Position.Node),
1840 "bad cursor in Replace_Element");
1842 Replace_Element (Container.Tree, Position.Node, New_Item);
1843 end Replace_Element;
1845 ---------------------
1846 -- Reverse_Iterate --
1847 ---------------------
1849 procedure Reverse_Iterate
1851 Item : Element_Type;
1852 Process : not null access procedure (Position : Cursor))
1854 procedure Process_Node (Node : Node_Access);
1855 pragma Inline (Process_Node);
1857 procedure Local_Reverse_Iterate is
1858 new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1864 procedure Process_Node (Node : Node_Access) is
1866 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1869 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
1870 B
: Natural renames T
.Busy
;
1872 -- Start of processing for Reverse_Iterate
1878 Local_Reverse_Iterate
(T
, Item
);
1886 end Reverse_Iterate
;
1888 procedure Reverse_Iterate
1890 Process
: not null access procedure (Position
: Cursor
))
1892 procedure Process_Node
(Node
: Node_Access
);
1893 pragma Inline
(Process_Node
);
1895 procedure Local_Reverse_Iterate
is
1896 new Tree_Operations
.Generic_Reverse_Iteration
(Process_Node
);
1902 procedure Process_Node
(Node
: Node_Access
) is
1904 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1907 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1908 B : Natural renames T.Busy;
1910 -- Start of processing for Reverse_Iterate
1916 Local_Reverse_Iterate (T);
1924 end Reverse_Iterate;
1930 function Right (Node : Node_Access) return Node_Access is
1939 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1941 Node.Color := Color;
1948 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1957 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1959 Node.Parent := Parent;
1966 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1968 Node.Right := Right;
1971 --------------------------
1972 -- Symmetric_Difference --
1973 --------------------------
1975 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1977 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1978 end Symmetric_Difference;
1980 function Symmetric_Difference (Left, Right : Set) return Set is
1981 Tree : constant Tree_Type :=
1982 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1984 return Set'(Controlled
with Tree
);
1985 end Symmetric_Difference
;
1991 function To_Set
(New_Item
: Element_Type
) return Set
is
1994 pragma Unreferenced
(Node
);
1996 Insert_Sans_Hint
(Tree
, New_Item
, Node
);
1997 return Set
'(Controlled with Tree);
2004 procedure Union (Target : in out Set; Source : Set) is
2006 Set_Ops.Union (Target.Tree, Source.Tree);
2009 function Union (Left, Right : Set) return Set is
2010 Tree : constant Tree_Type :=
2011 Set_Ops.Union (Left.Tree, Right.Tree);
2013 return Set'(Controlled
with Tree
);
2021 (Stream
: not null access Root_Stream_Type
'Class;
2024 procedure Write_Node
2025 (Stream
: not null access Root_Stream_Type
'Class;
2026 Node
: Node_Access
);
2027 pragma Inline
(Write_Node
);
2030 new Tree_Operations
.Generic_Write
(Write_Node
);
2036 procedure Write_Node
2037 (Stream
: not null access Root_Stream_Type
'Class;
2041 Element_Type
'Output (Stream
, Node
.Element
.all);
2044 -- Start of processing for Write
2047 Write
(Stream
, Container
.Tree
);
2051 (Stream
: not null access Root_Stream_Type
'Class;
2055 raise Program_Error
with "attempt to stream set cursor";
2058 end Ada
.Containers
.Indefinite_Ordered_Multisets
;