1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS --
9 -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Containers
.Red_Black_Trees
.Generic_Operations
;
31 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Operations
);
33 with Ada
.Containers
.Red_Black_Trees
.Generic_Keys
;
34 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Keys
);
36 with Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
;
37 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
);
39 with Ada
.Unchecked_Deallocation
;
41 with System
; use type System
.Address
;
43 package body Ada
.Containers
.Indefinite_Ordered_Sets
is
45 -----------------------
46 -- Local Subprograms --
47 -----------------------
49 function Color
(Node
: Node_Access
) return Color_Type
;
50 pragma Inline
(Color
);
52 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
53 pragma Inline
(Copy_Node
);
55 procedure Free
(X
: in out Node_Access
);
57 procedure Insert_Sans_Hint
58 (Tree
: in out Tree_Type
;
59 New_Item
: Element_Type
;
60 Node
: out Node_Access
;
61 Inserted
: out Boolean);
63 procedure Insert_With_Hint
64 (Dst_Tree
: in out Tree_Type
;
65 Dst_Hint
: Node_Access
;
66 Src_Node
: Node_Access
;
67 Dst_Node
: out Node_Access
);
69 function Is_Greater_Element_Node
71 Right
: Node_Access
) return Boolean;
72 pragma Inline
(Is_Greater_Element_Node
);
74 function Is_Less_Element_Node
76 Right
: Node_Access
) return Boolean;
77 pragma Inline
(Is_Less_Element_Node
);
79 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean;
80 pragma Inline
(Is_Less_Node_Node
);
82 function Left
(Node
: Node_Access
) return Node_Access
;
85 function Parent
(Node
: Node_Access
) return Node_Access
;
86 pragma Inline
(Parent
);
88 procedure Replace_Element
89 (Tree
: in out Tree_Type
;
93 function Right
(Node
: Node_Access
) return Node_Access
;
94 pragma Inline
(Right
);
96 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
97 pragma Inline
(Set_Color
);
99 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
100 pragma Inline
(Set_Left
);
102 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
103 pragma Inline
(Set_Parent
);
105 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
106 pragma Inline
(Set_Right
);
108 --------------------------
109 -- Local Instantiations --
110 --------------------------
112 procedure Free_Element
is
113 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
115 package Tree_Operations
is
116 new Red_Black_Trees
.Generic_Operations
(Tree_Types
);
118 procedure Delete_Tree
is
119 new Tree_Operations
.Generic_Delete_Tree
(Free
);
121 function Copy_Tree
is
122 new Tree_Operations
.Generic_Copy_Tree
(Copy_Node
, Delete_Tree
);
126 package Element_Keys
is
127 new Red_Black_Trees
.Generic_Keys
128 (Tree_Operations
=> Tree_Operations
,
129 Key_Type
=> Element_Type
,
130 Is_Less_Key_Node
=> Is_Less_Element_Node
,
131 Is_Greater_Key_Node
=> Is_Greater_Element_Node
);
134 new Generic_Set_Operations
135 (Tree_Operations
=> Tree_Operations
,
136 Insert_With_Hint
=> Insert_With_Hint
,
137 Copy_Tree
=> Copy_Tree
,
138 Delete_Tree
=> Delete_Tree
,
139 Is_Less
=> Is_Less_Node_Node
,
146 function "<" (Left
, Right
: Cursor
) return Boolean is
148 if Left
.Node
= null then
149 raise Constraint_Error
with "Left cursor equals No_Element";
152 if Right
.Node
= null then
153 raise Constraint_Error
with "Right cursor equals No_Element";
156 if Left
.Node
.Element
= null then
157 raise Program_Error
with "Left cursor is bad";
160 if Right
.Node
.Element
= null then
161 raise Program_Error
with "Right cursor is bad";
164 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
165 "bad Left cursor in ""<""");
167 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
168 "bad Right cursor in ""<""");
170 return Left
.Node
.Element
.all < Right
.Node
.Element
.all;
173 function "<" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
175 if Left
.Node
= null then
176 raise Constraint_Error
with "Left cursor equals No_Element";
179 if Left
.Node
.Element
= null then
180 raise Program_Error
with "Left cursor is bad";
183 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
184 "bad Left cursor in ""<""");
186 return Left
.Node
.Element
.all < Right
;
189 function "<" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
191 if Right
.Node
= null then
192 raise Constraint_Error
with "Right cursor equals No_Element";
195 if Right
.Node
.Element
= null then
196 raise Program_Error
with "Right cursor is bad";
199 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
200 "bad Right cursor in ""<""");
202 return Left
< Right
.Node
.Element
.all;
209 function "=" (Left
, Right
: Set
) return Boolean is
211 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean;
212 pragma Inline
(Is_Equal_Node_Node
);
215 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
217 ------------------------
218 -- Is_Equal_Node_Node --
219 ------------------------
221 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean is
223 return L
.Element
.all = R
.Element
.all;
224 end Is_Equal_Node_Node
;
226 -- Start of processing for "="
229 return Is_Equal
(Left
.Tree
, Right
.Tree
);
236 function ">" (Left
, Right
: Cursor
) return Boolean is
238 if Left
.Node
= null then
239 raise Constraint_Error
with "Left cursor equals No_Element";
242 if Right
.Node
= null then
243 raise Constraint_Error
with "Right cursor equals No_Element";
246 if Left
.Node
.Element
= null then
247 raise Program_Error
with "Left cursor is bad";
250 if Right
.Node
.Element
= null then
251 raise Program_Error
with "Right cursor is bad";
254 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
255 "bad Left cursor in "">""");
257 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
258 "bad Right cursor in "">""");
260 -- L > R same as R < L
262 return Right
.Node
.Element
.all < Left
.Node
.Element
.all;
265 function ">" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
267 if Left
.Node
= null then
268 raise Constraint_Error
with "Left cursor equals No_Element";
271 if Left
.Node
.Element
= null then
272 raise Program_Error
with "Left cursor is bad";
275 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
276 "bad Left cursor in "">""");
278 return Right
< Left
.Node
.Element
.all;
281 function ">" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
283 if Right
.Node
= null then
284 raise Constraint_Error
with "Right cursor equals No_Element";
287 if Right
.Node
.Element
= null then
288 raise Program_Error
with "Right cursor is bad";
291 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
292 "bad Right cursor in "">""");
294 return Right
.Node
.Element
.all < Left
;
301 procedure Adjust
is new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
303 procedure Adjust
(Container
: in out Set
) is
305 Adjust
(Container
.Tree
);
308 procedure Adjust
(Control
: in out Reference_Control_Type
) is
310 if Control
.Container
/= null then
312 Tree
: Tree_Type
renames Control
.Container
.all.Tree
;
313 B
: Natural renames Tree
.Busy
;
314 L
: Natural renames Tree
.Lock
;
326 procedure Assign
(Target
: in out Set
; Source
: Set
) is
328 if Target
'Address = Source
'Address then
333 Target
.Union
(Source
);
340 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
is
341 Node
: constant Node_Access
:=
342 Element_Keys
.Ceiling
(Container
.Tree
, Item
);
344 return (if Node
= null then No_Element
345 else Cursor
'(Container'Unrestricted_Access, Node));
353 new Tree_Operations.Generic_Clear (Delete_Tree);
355 procedure Clear (Container : in out Set) is
357 Clear (Container.Tree);
364 function Color (Node : Node_Access) return Color_Type is
369 ------------------------
370 -- Constant_Reference --
371 ------------------------
373 function Constant_Reference
374 (Container : aliased Set;
375 Position : Cursor) return Constant_Reference_Type
378 if Position.Container = null then
379 raise Constraint_Error with "Position cursor has no element";
382 if Position.Container /= Container'Unrestricted_Access then
383 raise Program_Error with
384 "Position cursor designates wrong container";
387 if Position.Node.Element = null then
388 raise Program_Error with "Node has no element";
392 (Vet (Container.Tree, Position.Node),
393 "bad cursor in Constant_Reference");
396 Tree : Tree_Type renames Position.Container.all.Tree;
397 B : Natural renames Tree.Busy;
398 L : Natural renames Tree.Lock;
400 return R : constant Constant_Reference_Type :=
401 (Element => Position.Node.Element.all'Access,
402 Control => (Controlled with Container'Unrestricted_Access))
408 end Constant_Reference;
414 function Contains (Container : Set; Item : Element_Type) return Boolean is
416 return Find (Container, Item) /= No_Element;
423 function Copy (Source : Set) return Set is
425 return Target : Set do
426 Target.Assign (Source);
434 function Copy_Node (Source : Node_Access) return Node_Access is
435 Element : Element_Access := new Element_Type'(Source
.Element
.all);
438 return new Node_Type
'(Parent => null,
441 Color => Source.Color,
445 Free_Element (Element);
453 procedure Delete (Container : in out Set; Position : in out Cursor) is
455 if Position.Node = null then
456 raise Constraint_Error with "Position cursor equals No_Element";
459 if Position.Node.Element = null then
460 raise Program_Error with "Position cursor is bad";
463 if Position.Container /= Container'Unrestricted_Access then
464 raise Program_Error with "Position cursor designates wrong set";
467 pragma Assert (Vet (Container.Tree, Position.Node),
468 "bad cursor in Delete");
470 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
471 Free (Position.Node);
472 Position.Container := null;
475 procedure Delete (Container : in out Set; Item : Element_Type) is
476 X : Node_Access := Element_Keys.Find (Container.Tree, Item);
479 raise Constraint_Error with "attempt to delete element not in set";
481 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
490 procedure Delete_First (Container : in out Set) is
491 Tree : Tree_Type renames Container.Tree;
492 X : Node_Access := Tree.First;
495 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
504 procedure Delete_Last (Container : in out Set) is
505 Tree : Tree_Type renames Container.Tree;
506 X : Node_Access := Tree.Last;
509 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
518 procedure Difference (Target : in out Set; Source : Set) is
520 Set_Ops.Difference (Target.Tree, Source.Tree);
523 function Difference (Left, Right : Set) return Set is
524 Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree);
526 return Set'(Controlled
with Tree
);
533 function Element
(Position
: Cursor
) return Element_Type
is
535 if Position
.Node
= null then
536 raise Constraint_Error
with "Position cursor equals No_Element";
539 if Position
.Node
.Element
= null then
540 raise Program_Error
with "Position cursor is bad";
543 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
544 "bad cursor in Element");
546 return Position
.Node
.Element
.all;
549 -------------------------
550 -- Equivalent_Elements --
551 -------------------------
553 function Equivalent_Elements
(Left
, Right
: Element_Type
) return Boolean is
555 if Left
< Right
or else Right
< Left
then
560 end Equivalent_Elements
;
562 ---------------------
563 -- Equivalent_Sets --
564 ---------------------
566 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
568 function Is_Equivalent_Node_Node
(L
, R
: Node_Access
) return Boolean;
569 pragma Inline
(Is_Equivalent_Node_Node
);
571 function Is_Equivalent
is
572 new Tree_Operations
.Generic_Equal
(Is_Equivalent_Node_Node
);
574 -----------------------------
575 -- Is_Equivalent_Node_Node --
576 -----------------------------
578 function Is_Equivalent_Node_Node
(L
, R
: Node_Access
) return Boolean is
580 if L
.Element
.all < R
.Element
.all then
582 elsif R
.Element
.all < L
.Element
.all then
587 end Is_Equivalent_Node_Node
;
589 -- Start of processing for Equivalent_Sets
592 return Is_Equivalent
(Left
.Tree
, Right
.Tree
);
599 procedure Exclude
(Container
: in out Set
; Item
: Element_Type
) is
600 X
: Node_Access
:= Element_Keys
.Find
(Container
.Tree
, Item
);
603 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
612 procedure Finalize
(Object
: in out Iterator
) is
614 if Object
.Container
/= null then
616 B
: Natural renames Object
.Container
.all.Tree
.Busy
;
623 procedure Finalize
(Control
: in out Reference_Control_Type
) is
625 if Control
.Container
/= null then
627 Tree
: Tree_Type
renames Control
.Container
.all.Tree
;
628 B
: Natural renames Tree
.Busy
;
629 L
: Natural renames Tree
.Lock
;
635 Control
.Container
:= null;
643 function Find
(Container
: Set
; Item
: Element_Type
) return Cursor
is
644 Node
: constant Node_Access
:= Element_Keys
.Find
(Container
.Tree
, Item
);
649 return Cursor
'(Container'Unrestricted_Access, Node);
657 function First (Container : Set) return Cursor is
660 (if Container.Tree.First = null then No_Element
661 else Cursor'(Container
'Unrestricted_Access, Container
.Tree
.First
));
664 function First
(Object
: Iterator
) return Cursor
is
666 -- The value of the iterator object's Node component influences the
667 -- behavior of the First (and Last) selector function.
669 -- When the Node component is null, this means the iterator object was
670 -- constructed without a start expression, in which case the (forward)
671 -- iteration starts from the (logical) beginning of the entire sequence
672 -- of items (corresponding to Container.First, for a forward iterator).
674 -- Otherwise, this is iteration over a partial sequence of items. When
675 -- the Node component is non-null, the iterator object was constructed
676 -- with a start expression, that specifies the position from which the
677 -- (forward) partial iteration begins.
679 if Object
.Node
= null then
680 return Object
.Container
.First
;
682 return Cursor
'(Object.Container, Object.Node);
690 function First_Element (Container : Set) return Element_Type is
692 if Container.Tree.First = null then
693 raise Constraint_Error with "set is empty";
695 return Container.Tree.First.Element.all;
703 function Floor (Container : Set; Item : Element_Type) return Cursor is
704 Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item);
706 return (if Node = null then No_Element
707 else Cursor'(Container
'Unrestricted_Access, Node
));
714 procedure Free
(X
: in out Node_Access
) is
715 procedure Deallocate
is
716 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
728 Free_Element
(X
.Element
);
743 package body Generic_Keys
is
745 -----------------------
746 -- Local Subprograms --
747 -----------------------
749 function Is_Greater_Key_Node
751 Right
: Node_Access
) return Boolean;
752 pragma Inline
(Is_Greater_Key_Node
);
754 function Is_Less_Key_Node
756 Right
: Node_Access
) return Boolean;
757 pragma Inline
(Is_Less_Key_Node
);
759 --------------------------
760 -- Local Instantiations --
761 --------------------------
764 new Red_Black_Trees
.Generic_Keys
765 (Tree_Operations
=> Tree_Operations
,
766 Key_Type
=> Key_Type
,
767 Is_Less_Key_Node
=> Is_Less_Key_Node
,
768 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
774 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
is
775 Node
: constant Node_Access
:= Key_Keys
.Ceiling
(Container
.Tree
, Key
);
777 return (if Node
= null then No_Element
778 else Cursor
'(Container'Unrestricted_Access, Node));
781 ------------------------
782 -- Constant_Reference --
783 ------------------------
785 function Constant_Reference
786 (Container : aliased Set;
787 Key : Key_Type) return Constant_Reference_Type
789 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
793 raise Constraint_Error with "Key not in set";
796 if Node.Element = null then
797 raise Program_Error with "Node has no element";
801 Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
802 B : Natural renames Tree.Busy;
803 L : Natural renames Tree.Lock;
805 return R : constant Constant_Reference_Type :=
806 (Element => Node.Element.all'Access,
807 Control => (Controlled with Container'Unrestricted_Access))
813 end Constant_Reference;
819 function Contains (Container : Set; Key : Key_Type) return Boolean is
821 return Find (Container, Key) /= No_Element;
828 procedure Delete (Container : in out Set; Key : Key_Type) is
829 X : Node_Access := Key_Keys.Find (Container.Tree, Key);
833 raise Constraint_Error with "attempt to delete key not in set";
836 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
844 function Element (Container : Set; Key : Key_Type) return Element_Type is
845 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
848 raise Constraint_Error with "key not in set";
850 return Node.Element.all;
854 ---------------------
855 -- Equivalent_Keys --
856 ---------------------
858 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
860 if Left < Right or else Right < Left then
871 procedure Exclude (Container : in out Set; Key : Key_Type) is
872 X : Node_Access := Key_Keys.Find (Container.Tree, Key);
875 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
884 function Find (Container : Set; Key : Key_Type) return Cursor is
885 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
887 return (if Node = null then No_Element
888 else Cursor'(Container
'Unrestricted_Access, Node
));
895 function Floor
(Container
: Set
; Key
: Key_Type
) return Cursor
is
896 Node
: constant Node_Access
:= Key_Keys
.Floor
(Container
.Tree
, Key
);
898 return (if Node
= null then No_Element
899 else Cursor
'(Container'Unrestricted_Access, Node));
902 -------------------------
903 -- Is_Greater_Key_Node --
904 -------------------------
906 function Is_Greater_Key_Node
908 Right : Node_Access) return Boolean
911 return Key (Right.Element.all) < Left;
912 end Is_Greater_Key_Node;
914 ----------------------
915 -- Is_Less_Key_Node --
916 ----------------------
918 function Is_Less_Key_Node
920 Right : Node_Access) return Boolean
923 return Left < Key (Right.Element.all);
924 end Is_Less_Key_Node;
930 function Key (Position : Cursor) return Key_Type is
932 if Position.Node = null then
933 raise Constraint_Error with
934 "Position cursor equals No_Element";
937 if Position.Node.Element = null then
938 raise Program_Error with
939 "Position cursor is bad";
942 pragma Assert (Vet (Position.Container.Tree, Position.Node),
943 "bad cursor in Key");
945 return Key (Position.Node.Element.all);
953 (Container : in out Set;
955 New_Item : Element_Type)
957 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
961 raise Constraint_Error with
962 "attempt to replace key not in set";
965 Replace_Element (Container.Tree, Node, New_Item);
973 (Stream : not null access Root_Stream_Type'Class;
974 Item : out Reference_Type)
977 raise Program_Error with "attempt to stream reference";
980 ------------------------------
981 -- Reference_Preserving_Key --
982 ------------------------------
984 function Reference_Preserving_Key
985 (Container : aliased in out Set;
986 Position : Cursor) return Reference_Type
989 if Position.Container = null then
990 raise Constraint_Error with "Position cursor has no element";
993 if Position.Container /= Container'Unrestricted_Access then
994 raise Program_Error with
995 "Position cursor designates wrong container";
998 if Position.Node.Element = null then
999 raise Program_Error with "Node has no element";
1003 (Vet (Container.Tree, Position.Node),
1004 "bad cursor in function Reference_Preserving_Key");
1006 -- Some form of finalization will be required in order to actually
1007 -- check that the key-part of the element designated by Position has
1010 return (Element => Position.Node.Element.all'Access);
1011 end Reference_Preserving_Key;
1013 function Reference_Preserving_Key
1014 (Container : aliased in out Set;
1015 Key : Key_Type) return Reference_Type
1017 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
1021 raise Constraint_Error with "Key not in set";
1024 if Node.Element = null then
1025 raise Program_Error with "Node has no element";
1028 -- Some form of finalization will be required in order to actually
1029 -- check that the key-part of the element designated by Key has not
1032 return (Element => Node.Element.all'Access);
1033 end Reference_Preserving_Key;
1035 -----------------------------------
1036 -- Update_Element_Preserving_Key --
1037 -----------------------------------
1039 procedure Update_Element_Preserving_Key
1040 (Container : in out Set;
1042 Process : not null access
1043 procedure (Element : in out Element_Type))
1045 Tree : Tree_Type renames Container.Tree;
1048 if Position.Node = null then
1049 raise Constraint_Error with "Position cursor equals No_Element";
1052 if Position.Node.Element = null then
1053 raise Program_Error with "Position cursor is bad";
1056 if Position.Container /= Container'Unrestricted_Access then
1057 raise Program_Error with "Position cursor designates wrong set";
1060 pragma Assert (Vet (Container.Tree, Position.Node),
1061 "bad cursor in Update_Element_Preserving_Key");
1064 E : Element_Type renames Position.Node.Element.all;
1065 K : constant Key_Type := Key (E);
1067 B : Natural renames Tree.Busy;
1068 L : Natural renames Tree.Lock;
1078 Eq := Equivalent_Keys (K, Key (E));
1095 X : Node_Access := Position.Node;
1097 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
1101 raise Program_Error with "key was modified";
1102 end Update_Element_Preserving_Key;
1109 (Stream : not null access Root_Stream_Type'Class;
1110 Item : Reference_Type)
1113 raise Program_Error with "attempt to stream reference";
1122 function Has_Element (Position : Cursor) return Boolean is
1124 return Position /= No_Element;
1131 procedure Include (Container : in out Set; New_Item : Element_Type) is
1138 Insert (Container, New_Item, Position, Inserted);
1140 if not Inserted then
1141 if Container.Tree.Lock > 0 then
1142 raise Program_Error with
1143 "attempt to tamper with elements (set is locked)";
1147 -- The element allocator may need an accessibility check in the
1148 -- case the actual type is class-wide or has access discriminants
1149 -- (see RM 4.8(10.1) and AI12-0035).
1151 pragma Unsuppress (Accessibility_Check);
1154 X := Position.Node.Element;
1155 Position.Node.Element := new Element_Type'(New_Item
);
1166 (Container
: in out Set
;
1167 New_Item
: Element_Type
;
1168 Position
: out Cursor
;
1169 Inserted
: out Boolean)
1178 Position
.Container
:= Container
'Unrestricted_Access;
1181 procedure Insert
(Container
: in out Set
; New_Item
: Element_Type
) is
1183 pragma Unreferenced
(Position
);
1188 Insert
(Container
, New_Item
, Position
, Inserted
);
1190 if not Inserted
then
1191 raise Constraint_Error
with
1192 "attempt to insert element already in set";
1196 ----------------------
1197 -- Insert_Sans_Hint --
1198 ----------------------
1200 procedure Insert_Sans_Hint
1201 (Tree
: in out Tree_Type
;
1202 New_Item
: Element_Type
;
1203 Node
: out Node_Access
;
1204 Inserted
: out Boolean)
1206 function New_Node
return Node_Access
;
1207 pragma Inline
(New_Node
);
1209 procedure Insert_Post
is
1210 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1212 procedure Conditional_Insert_Sans_Hint
is
1213 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
1219 function New_Node
return Node_Access
is
1220 -- The element allocator may need an accessibility check in the case
1221 -- the actual type is class-wide or has access discriminants (see
1222 -- RM 4.8(10.1) and AI12-0035).
1224 pragma Unsuppress
(Accessibility_Check
);
1226 Element
: Element_Access
:= new Element_Type
'(New_Item);
1229 return new Node_Type'(Parent
=> null,
1232 Color
=> Red_Black_Trees
.Red
,
1233 Element
=> Element
);
1237 Free_Element
(Element
);
1241 -- Start of processing for Insert_Sans_Hint
1244 Conditional_Insert_Sans_Hint
1249 end Insert_Sans_Hint
;
1251 ----------------------
1252 -- Insert_With_Hint --
1253 ----------------------
1255 procedure Insert_With_Hint
1256 (Dst_Tree
: in out Tree_Type
;
1257 Dst_Hint
: Node_Access
;
1258 Src_Node
: Node_Access
;
1259 Dst_Node
: out Node_Access
)
1262 pragma Unreferenced
(Success
);
1264 function New_Node
return Node_Access
;
1266 procedure Insert_Post
is
1267 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1269 procedure Insert_Sans_Hint
is
1270 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
1272 procedure Insert_With_Hint
is
1273 new Element_Keys
.Generic_Conditional_Insert_With_Hint
1281 function New_Node
return Node_Access
is
1282 Element
: Element_Access
:= new Element_Type
'(Src_Node.Element.all);
1287 Node := new Node_Type;
1290 Free_Element (Element);
1294 Node.Element := Element;
1298 -- Start of processing for Insert_With_Hint
1304 Src_Node.Element.all,
1307 end Insert_With_Hint;
1313 procedure Intersection (Target : in out Set; Source : Set) is
1315 Set_Ops.Intersection (Target.Tree, Source.Tree);
1318 function Intersection (Left, Right : Set) return Set is
1319 Tree : constant Tree_Type :=
1320 Set_Ops.Intersection (Left.Tree, Right.Tree);
1322 return Set'(Controlled
with Tree
);
1329 function Is_Empty
(Container
: Set
) return Boolean is
1331 return Container
.Tree
.Length
= 0;
1334 -----------------------------
1335 -- Is_Greater_Element_Node --
1336 -----------------------------
1338 function Is_Greater_Element_Node
1339 (Left
: Element_Type
;
1340 Right
: Node_Access
) return Boolean
1343 -- e > node same as node < e
1345 return Right
.Element
.all < Left
;
1346 end Is_Greater_Element_Node
;
1348 --------------------------
1349 -- Is_Less_Element_Node --
1350 --------------------------
1352 function Is_Less_Element_Node
1353 (Left
: Element_Type
;
1354 Right
: Node_Access
) return Boolean
1357 return Left
< Right
.Element
.all;
1358 end Is_Less_Element_Node
;
1360 -----------------------
1361 -- Is_Less_Node_Node --
1362 -----------------------
1364 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean is
1366 return L
.Element
.all < R
.Element
.all;
1367 end Is_Less_Node_Node
;
1373 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
1375 return Set_Ops
.Is_Subset
(Subset
=> Subset
.Tree
, Of_Set
=> Of_Set
.Tree
);
1384 Process
: not null access procedure (Position
: Cursor
))
1386 procedure Process_Node
(Node
: Node_Access
);
1387 pragma Inline
(Process_Node
);
1389 procedure Local_Iterate
is
1390 new Tree_Operations
.Generic_Iteration
(Process_Node
);
1396 procedure Process_Node
(Node
: Node_Access
) is
1398 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1401 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1402 B : Natural renames T.Busy;
1404 -- Start of processing for Iterate
1422 return Set_Iterator_Interfaces.Reversible_Iterator'class
1424 B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1427 -- The value of the Node component influences the behavior of the First
1428 -- and Last selector functions of the iterator object. When the Node
1429 -- component is null (as is the case here), this means the iterator
1430 -- object was constructed without a start expression. This is a complete
1431 -- iterator, meaning that the iteration starts from the (logical)
1432 -- beginning of the sequence of items.
1434 -- Note: For a forward iterator, Container.First is the beginning, and
1435 -- for a reverse iterator, Container.Last is the beginning.
1437 return It : constant Iterator :=
1438 Iterator'(Limited_Controlled
with
1439 Container
=> Container
'Unrestricted_Access,
1449 return Set_Iterator_Interfaces
.Reversible_Iterator
'class
1451 B
: Natural renames Container
'Unrestricted_Access.all.Tree
.Busy
;
1454 -- It was formerly the case that when Start = No_Element, the partial
1455 -- iterator was defined to behave the same as for a complete iterator,
1456 -- and iterate over the entire sequence of items. However, those
1457 -- semantics were unintuitive and arguably error-prone (it is too easy
1458 -- to accidentally create an endless loop), and so they were changed,
1459 -- per the ARG meeting in Denver on 2011/11. However, there was no
1460 -- consensus about what positive meaning this corner case should have,
1461 -- and so it was decided to simply raise an exception. This does imply,
1462 -- however, that it is not possible to use a partial iterator to specify
1463 -- an empty sequence of items.
1465 if Start
= No_Element
then
1466 raise Constraint_Error
with
1467 "Start position for iterator equals No_Element";
1470 if Start
.Container
/= Container
'Unrestricted_Access then
1471 raise Program_Error
with
1472 "Start cursor of Iterate designates wrong set";
1475 pragma Assert
(Vet
(Container
.Tree
, Start
.Node
),
1476 "Start cursor of Iterate is bad");
1478 -- The value of the Node component influences the behavior of the First
1479 -- and Last selector functions of the iterator object. When the Node
1480 -- component is non-null (as is the case here), it means that this is a
1481 -- partial iteration, over a subset of the complete sequence of
1482 -- items. The iterator object was constructed with a start expression,
1483 -- indicating the position from which the iteration begins. Note that
1484 -- the start position has the same value irrespective of whether this is
1485 -- a forward or reverse iteration.
1487 return It
: constant Iterator
:=
1488 (Limited_Controlled
with
1489 Container
=> Container
'Unrestricted_Access,
1500 function Last
(Container
: Set
) return Cursor
is
1503 (if Container
.Tree
.Last
= null then No_Element
1504 else Cursor
'(Container'Unrestricted_Access, Container.Tree.Last));
1507 function Last (Object : Iterator) return Cursor is
1509 -- The value of the iterator object's Node component influences the
1510 -- behavior of the Last (and First) selector function.
1512 -- When the Node component is null, this means the iterator object was
1513 -- constructed without a start expression, in which case the (reverse)
1514 -- iteration starts from the (logical) beginning of the entire sequence
1515 -- (corresponding to Container.Last, for a reverse iterator).
1517 -- Otherwise, this is iteration over a partial sequence of items. When
1518 -- the Node component is non-null, the iterator object was constructed
1519 -- with a start expression, that specifies the position from which the
1520 -- (reverse) partial iteration begins.
1522 if Object.Node = null then
1523 return Object.Container.Last;
1525 return Cursor'(Object
.Container
, Object
.Node
);
1533 function Last_Element
(Container
: Set
) return Element_Type
is
1535 if Container
.Tree
.Last
= null then
1536 raise Constraint_Error
with "set is empty";
1538 return Container
.Tree
.Last
.Element
.all;
1546 function Left
(Node
: Node_Access
) return Node_Access
is
1555 function Length
(Container
: Set
) return Count_Type
is
1557 return Container
.Tree
.Length
;
1564 procedure Move
is new Tree_Operations
.Generic_Move
(Clear
);
1566 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1568 Move
(Target
=> Target
.Tree
, Source
=> Source
.Tree
);
1575 procedure Next
(Position
: in out Cursor
) is
1577 Position
:= Next
(Position
);
1580 function Next
(Position
: Cursor
) return Cursor
is
1582 if Position
= No_Element
then
1586 if Position
.Node
.Element
= null then
1587 raise Program_Error
with "Position cursor is bad";
1590 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1591 "bad cursor in Next");
1594 Node
: constant Node_Access
:= Tree_Operations
.Next
(Position
.Node
);
1596 return (if Node
= null then No_Element
1597 else Cursor
'(Position.Container, Node));
1603 Position : Cursor) return Cursor
1606 if Position.Container = null then
1610 if Position.Container /= Object.Container then
1611 raise Program_Error with
1612 "Position cursor of Next designates wrong set";
1615 return Next (Position);
1622 function Overlap (Left, Right : Set) return Boolean is
1624 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1631 function Parent (Node : Node_Access) return Node_Access is
1640 procedure Previous (Position : in out Cursor) is
1642 Position := Previous (Position);
1645 function Previous (Position : Cursor) return Cursor is
1647 if Position = No_Element then
1651 if Position.Node.Element = null then
1652 raise Program_Error with "Position cursor is bad";
1655 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1656 "bad cursor in Previous");
1659 Node : constant Node_Access :=
1660 Tree_Operations.Previous (Position.Node);
1662 return (if Node = null then No_Element
1663 else Cursor'(Position
.Container
, Node
));
1669 Position
: Cursor
) return Cursor
1672 if Position
.Container
= null then
1676 if Position
.Container
/= Object
.Container
then
1677 raise Program_Error
with
1678 "Position cursor of Previous designates wrong set";
1681 return Previous
(Position
);
1688 procedure Query_Element
1690 Process
: not null access procedure (Element
: Element_Type
))
1693 if Position
.Node
= null then
1694 raise Constraint_Error
with "Position cursor equals No_Element";
1697 if Position
.Node
.Element
= null then
1698 raise Program_Error
with "Position cursor is bad";
1701 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1702 "bad cursor in Query_Element");
1705 T
: Tree_Type
renames Position
.Container
.Tree
;
1707 B
: Natural renames T
.Busy
;
1708 L
: Natural renames T
.Lock
;
1715 Process
(Position
.Node
.Element
.all);
1733 (Stream
: not null access Root_Stream_Type
'Class;
1734 Container
: out Set
)
1737 (Stream
: not null access Root_Stream_Type
'Class) return Node_Access
;
1738 pragma Inline
(Read_Node
);
1741 new Tree_Operations
.Generic_Read
(Clear
, Read_Node
);
1748 (Stream
: not null access Root_Stream_Type
'Class) return Node_Access
1750 Node
: Node_Access
:= new Node_Type
;
1753 Node
.Element
:= new Element_Type
'(Element_Type'Input (Stream));
1758 Free (Node); -- Note that Free deallocates elem too
1762 -- Start of processing for Read
1765 Read (Stream, Container.Tree);
1769 (Stream : not null access Root_Stream_Type'Class;
1773 raise Program_Error with "attempt to stream set cursor";
1777 (Stream : not null access Root_Stream_Type'Class;
1778 Item : out Constant_Reference_Type)
1781 raise Program_Error with "attempt to stream reference";
1788 procedure Replace (Container : in out Set; New_Item : Element_Type) is
1789 Node : constant Node_Access :=
1790 Element_Keys.Find (Container.Tree, New_Item);
1793 pragma Warnings (Off, X);
1797 raise Constraint_Error with "attempt to replace element not in set";
1800 if Container.Tree.Lock > 0 then
1801 raise Program_Error with
1802 "attempt to tamper with elements (set is locked)";
1806 -- The element allocator may need an accessibility check in the case
1807 -- the actual type is class-wide or has access discriminants (see
1808 -- RM 4.8(10.1) and AI12-0035).
1810 pragma Unsuppress (Accessibility_Check);
1814 Node.Element := new Element_Type'(New_Item
);
1819 ---------------------
1820 -- Replace_Element --
1821 ---------------------
1823 procedure Replace_Element
1824 (Tree
: in out Tree_Type
;
1826 Item
: Element_Type
)
1828 pragma Assert
(Node
/= null);
1829 pragma Assert
(Node
.Element
/= null);
1831 function New_Node
return Node_Access
;
1832 pragma Inline
(New_Node
);
1834 procedure Local_Insert_Post
is
1835 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1837 procedure Local_Insert_Sans_Hint
is
1838 new Element_Keys
.Generic_Conditional_Insert
(Local_Insert_Post
);
1840 procedure Local_Insert_With_Hint
is
1841 new Element_Keys
.Generic_Conditional_Insert_With_Hint
1843 Local_Insert_Sans_Hint
);
1849 function New_Node
return Node_Access
is
1851 -- The element allocator may need an accessibility check in the case
1852 -- the actual type is class-wide or has access discriminants (see
1853 -- RM 4.8(10.1) and AI12-0035).
1855 pragma Unsuppress
(Accessibility_Check
);
1858 Node
.Element
:= new Element_Type
'(Item); -- OK if fails
1860 Node.Parent := null;
1867 Result : Node_Access;
1871 X : Element_Access := Node.Element;
1873 -- Per AI05-0022, the container implementation is required to detect
1874 -- element tampering by a generic actual subprogram.
1876 B : Natural renames Tree.Busy;
1877 L : Natural renames Tree.Lock;
1879 -- Start of processing for Replace_Element
1882 -- Replace_Element assigns value Item to the element designated by Node,
1883 -- per certain semantic constraints, described as follows.
1885 -- If Item is equivalent to the element, then element is replaced and
1886 -- there's nothing else to do. This is the easy case.
1888 -- If Item is not equivalent, then the node will (possibly) have to move
1889 -- to some other place in the tree. This is slighly more complicated,
1890 -- because we must ensure that Item is not equivalent to some other
1891 -- element in the tree (in which case, the replacement is not allowed).
1893 -- Determine whether Item is equivalent to element on the specified
1900 Compare := (if Item < Node.Element.all then False
1901 elsif Node.Element.all < Item then False
1915 -- Item is equivalent to the node's element, so we will not have to
1918 if Tree.Lock > 0 then
1919 raise Program_Error with
1920 "attempt to tamper with elements (set is locked)";
1924 -- The element allocator may need an accessibility check in the
1925 -- case the actual type is class-wide or has access discriminants
1926 -- (see RM 4.8(10.1) and AI12-0035).
1928 pragma Unsuppress (Accessibility_Check);
1931 Node.Element := new Element_Type'(Item
);
1938 -- The replacement Item is not equivalent to the element on the
1939 -- specified node, which means that it will need to be re-inserted in a
1940 -- different position in the tree. We must now determine whether Item is
1941 -- equivalent to some other element in the tree (which would prohibit
1942 -- the assignment and hence the move).
1944 -- Ceiling returns the smallest element equivalent or greater than the
1945 -- specified Item; if there is no such element, then it returns null.
1947 Hint
:= Element_Keys
.Ceiling
(Tree
, Item
);
1949 if Hint
/= null then
1954 Compare
:= Item
< Hint
.Element
.all;
1966 -- Item >= Hint.Element
1970 -- Ceiling returns an element that is equivalent or greater
1971 -- than Item. If Item is "not less than" the element, then
1972 -- by elimination we know that Item is equivalent to the element.
1974 -- But this means that it is not possible to assign the value of
1975 -- Item to the specified element (on Node), because a different
1976 -- element (on Hint) equivalent to Item already exsits. (Were we
1977 -- to change Node's element value, we would have to move Node, but
1978 -- we would be unable to move the Node, because its new position
1979 -- in the tree is already occupied by an equivalent element.)
1981 raise Program_Error
with "attempt to replace existing element";
1984 -- Item is not equivalent to any other element in the tree, so it is
1985 -- safe to assign the value of Item to Node.Element. This means that
1986 -- the node will have to move to a different position in the tree
1987 -- (because its element will have a different value).
1989 -- The nearest (greater) neighbor of Item is Hint. This will be the
1990 -- insertion position of Node (because its element will have Item as
1993 -- If Node equals Hint, the relative position of Node does not
1994 -- change. This allows us to perform an optimization: we need not
1995 -- remove Node from the tree and then reinsert it with its new value,
1996 -- because it would only be placed in the exact same position.
1999 if Tree
.Lock
> 0 then
2000 raise Program_Error
with
2001 "attempt to tamper with elements (set is locked)";
2005 -- The element allocator may need an accessibility check in the
2006 -- case actual type is class-wide or has access discriminants
2007 -- (see RM 4.8(10.1) and AI12-0035).
2009 pragma Unsuppress
(Accessibility_Check
);
2012 Node
.Element
:= new Element_Type
'(Item);
2020 -- If we get here, it is because Item was greater than all elements in
2021 -- the tree (Hint = null), or because Item was less than some element at
2022 -- a different place in the tree (Item < Hint.Element.all). In either
2023 -- case, we remove Node from the tree (without actually deallocating
2024 -- it), and then insert Item into the tree, onto the same Node (so no
2025 -- new node is actually allocated).
2027 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
2029 Local_Insert_With_Hint
2034 Inserted => Inserted);
2036 pragma Assert (Inserted);
2037 pragma Assert (Result = Node);
2040 end Replace_Element;
2042 procedure Replace_Element
2043 (Container : in out Set;
2045 New_Item : Element_Type)
2048 if Position.Node = null then
2049 raise Constraint_Error with "Position cursor equals No_Element";
2052 if Position.Node.Element = null then
2053 raise Program_Error with "Position cursor is bad";
2056 if Position.Container /= Container'Unrestricted_Access then
2057 raise Program_Error with "Position cursor designates wrong set";
2060 pragma Assert (Vet (Container.Tree, Position.Node),
2061 "bad cursor in Replace_Element");
2063 Replace_Element (Container.Tree, Position.Node, New_Item);
2064 end Replace_Element;
2066 ---------------------
2067 -- Reverse_Iterate --
2068 ---------------------
2070 procedure Reverse_Iterate
2072 Process : not null access procedure (Position : Cursor))
2074 procedure Process_Node (Node : Node_Access);
2075 pragma Inline (Process_Node);
2077 procedure Local_Reverse_Iterate is
2078 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
2084 procedure Process_Node (Node : Node_Access) is
2086 Process (Cursor'(Container
'Unrestricted_Access, Node
));
2089 T
: Tree_Type
renames Container
.Tree
'Unrestricted_Access.all;
2090 B
: Natural renames T
.Busy
;
2092 -- Start of processing for Reverse_Iterate
2098 Local_Reverse_Iterate
(T
);
2106 end Reverse_Iterate
;
2112 function Right
(Node
: Node_Access
) return Node_Access
is
2121 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
) is
2123 Node
.Color
:= Color
;
2130 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
) is
2139 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
) is
2141 Node
.Parent
:= Parent
;
2148 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
) is
2150 Node
.Right
:= Right
;
2153 --------------------------
2154 -- Symmetric_Difference --
2155 --------------------------
2157 procedure Symmetric_Difference
(Target
: in out Set
; Source
: Set
) is
2159 Set_Ops
.Symmetric_Difference
(Target
.Tree
, Source
.Tree
);
2160 end Symmetric_Difference
;
2162 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
2163 Tree
: constant Tree_Type
:=
2164 Set_Ops
.Symmetric_Difference
(Left
.Tree
, Right
.Tree
);
2166 return Set
'(Controlled with Tree);
2167 end Symmetric_Difference;
2173 function To_Set (New_Item : Element_Type) return Set is
2177 pragma Unreferenced (Node, Inserted);
2179 Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
2180 return Set'(Controlled
with Tree
);
2187 procedure Union
(Target
: in out Set
; Source
: Set
) is
2189 Set_Ops
.Union
(Target
.Tree
, Source
.Tree
);
2192 function Union
(Left
, Right
: Set
) return Set
is
2193 Tree
: constant Tree_Type
:= Set_Ops
.Union
(Left
.Tree
, Right
.Tree
);
2195 return Set
'(Controlled with Tree);
2203 (Stream : not null access Root_Stream_Type'Class;
2206 procedure Write_Node
2207 (Stream : not null access Root_Stream_Type'Class;
2208 Node : Node_Access);
2209 pragma Inline (Write_Node);
2212 new Tree_Operations.Generic_Write (Write_Node);
2218 procedure Write_Node
2219 (Stream : not null access Root_Stream_Type'Class;
2223 Element_Type'Output (Stream, Node.Element.all);
2226 -- Start of processing for Write
2229 Write (Stream, Container.Tree);
2233 (Stream : not null access Root_Stream_Type'Class;
2237 raise Program_Error with "attempt to stream set cursor";
2241 (Stream : not null access Root_Stream_Type'Class;
2242 Item : Constant_Reference_Type)
2245 raise Program_Error with "attempt to stream reference";
2248 end Ada.Containers.Indefinite_Ordered_Sets;