1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . O R D E R E D _ S E T S --
9 -- Copyright (C) 2004-2024, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Unchecked_Deallocation
;
32 with Ada
.Containers
.Helpers
; use Ada
.Containers
.Helpers
;
34 with Ada
.Containers
.Red_Black_Trees
.Generic_Operations
;
35 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Operations
);
37 with Ada
.Containers
.Red_Black_Trees
.Generic_Keys
;
38 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Keys
);
40 with Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
;
41 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
);
43 with System
; use type System
.Address
;
44 with System
.Put_Images
;
46 package body Ada
.Containers
.Ordered_Sets
with
50 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
51 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
52 -- See comment in Ada.Containers.Helpers
54 ------------------------------
55 -- Access to Fields of Node --
56 ------------------------------
58 -- These subprograms provide functional notation for access to fields
59 -- of a node, and procedural notation for modifying these fields.
61 function Color
(Node
: Node_Access
) return Color_Type
;
62 pragma Inline
(Color
);
64 function Left
(Node
: Node_Access
) return Node_Access
;
67 function Parent
(Node
: Node_Access
) return Node_Access
;
68 pragma Inline
(Parent
);
70 function Right
(Node
: Node_Access
) return Node_Access
;
71 pragma Inline
(Right
);
73 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
74 pragma Inline
(Set_Color
);
76 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
77 pragma Inline
(Set_Left
);
79 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
80 pragma Inline
(Set_Right
);
82 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
83 pragma Inline
(Set_Parent
);
85 -----------------------
86 -- Local Subprograms --
87 -----------------------
89 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
90 pragma Inline
(Copy_Node
);
92 procedure Free
(X
: in out Node_Access
);
94 procedure Insert_Sans_Hint
95 (Tree
: in out Tree_Type
;
96 New_Item
: Element_Type
;
97 Node
: out Node_Access
;
98 Inserted
: out Boolean);
100 procedure Insert_With_Hint
101 (Dst_Tree
: in out Tree_Type
;
102 Dst_Hint
: Node_Access
;
103 Src_Node
: Node_Access
;
104 Dst_Node
: out Node_Access
);
106 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean;
107 pragma Inline
(Is_Equal_Node_Node
);
109 function Is_Greater_Element_Node
110 (Left
: Element_Type
;
111 Right
: Node_Access
) return Boolean;
112 pragma Inline
(Is_Greater_Element_Node
);
114 function Is_Less_Element_Node
115 (Left
: Element_Type
;
116 Right
: Node_Access
) return Boolean;
117 pragma Inline
(Is_Less_Element_Node
);
119 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean;
120 pragma Inline
(Is_Less_Node_Node
);
122 procedure Replace_Element
123 (Tree
: in out Tree_Type
;
125 Item
: Element_Type
);
127 --------------------------
128 -- Local Instantiations --
129 --------------------------
131 package Tree_Operations
is
132 new Red_Black_Trees
.Generic_Operations
(Tree_Types
);
134 procedure Delete_Tree
is
135 new Tree_Operations
.Generic_Delete_Tree
(Free
);
137 function Copy_Tree
is
138 new Tree_Operations
.Generic_Copy_Tree
(Copy_Node
, Delete_Tree
);
143 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
145 package Element_Keys
is
146 new Red_Black_Trees
.Generic_Keys
147 (Tree_Operations
=> Tree_Operations
,
148 Key_Type
=> Element_Type
,
149 Is_Less_Key_Node
=> Is_Less_Element_Node
,
150 Is_Greater_Key_Node
=> Is_Greater_Element_Node
);
153 new Generic_Set_Operations
154 (Tree_Operations
=> Tree_Operations
,
155 Insert_With_Hint
=> Insert_With_Hint
,
156 Copy_Tree
=> Copy_Tree
,
157 Delete_Tree
=> Delete_Tree
,
158 Is_Less
=> Is_Less_Node_Node
,
165 function "<" (Left
, Right
: Cursor
) return Boolean is
167 if Checks
and then Left
.Node
= null then
168 raise Constraint_Error
with "Left cursor equals No_Element";
171 if Checks
and then Right
.Node
= null then
172 raise Constraint_Error
with "Right cursor equals No_Element";
175 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
176 "bad Left cursor in ""<""");
178 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
179 "bad Right cursor in ""<""");
181 return Left
.Node
.Element
< Right
.Node
.Element
;
184 function "<" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
186 if Checks
and then Left
.Node
= null then
187 raise Constraint_Error
with "Left cursor equals No_Element";
190 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
191 "bad Left cursor in ""<""");
193 return Left
.Node
.Element
< Right
;
196 function "<" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
198 if Checks
and then Right
.Node
= null then
199 raise Constraint_Error
with "Right cursor equals No_Element";
202 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
203 "bad Right cursor in ""<""");
205 return Left
< Right
.Node
.Element
;
212 function "=" (Left
, Right
: Set
) return Boolean is
214 return Is_Equal
(Left
.Tree
, Right
.Tree
);
221 function ">" (Left
, Right
: Cursor
) return Boolean is
223 if Checks
and then Left
.Node
= null then
224 raise Constraint_Error
with "Left cursor equals No_Element";
227 if Checks
and then Right
.Node
= null then
228 raise Constraint_Error
with "Right cursor equals No_Element";
231 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
232 "bad Left cursor in "">""");
234 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
235 "bad Right cursor in "">""");
237 -- L > R same as R < L
239 return Right
.Node
.Element
< Left
.Node
.Element
;
242 function ">" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
244 if Checks
and then Right
.Node
= null then
245 raise Constraint_Error
with "Right cursor equals No_Element";
248 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
249 "bad Right cursor in "">""");
251 return Right
.Node
.Element
< Left
;
254 function ">" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
256 if Checks
and then Left
.Node
= null then
257 raise Constraint_Error
with "Left cursor equals No_Element";
260 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
261 "bad Left cursor in "">""");
263 return Right
< Left
.Node
.Element
;
270 procedure Adjust
is new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
272 procedure Adjust
(Container
: in out Set
) is
274 Adjust
(Container
.Tree
);
281 procedure Assign
(Target
: in out Set
; Source
: Set
) is
283 if Target
'Address = Source
'Address then
288 Target
.Union
(Source
);
295 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
is
296 Node
: constant Node_Access
:=
297 Element_Keys
.Ceiling
(Container
.Tree
, Item
);
299 return (if Node
= null then No_Element
300 else Cursor
'(Container'Unrestricted_Access, Node));
307 procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree);
309 procedure Clear (Container : in out Set) is
311 Clear (Container.Tree);
318 function Color (Node : Node_Access) return Color_Type is
323 ------------------------
324 -- Constant_Reference --
325 ------------------------
327 function Constant_Reference
328 (Container : aliased Set;
329 Position : Cursor) return Constant_Reference_Type
332 if Checks and then Position.Container = null then
333 raise Constraint_Error with "Position cursor has no element";
336 if Checks and then Position.Container /= Container'Unrestricted_Access
338 raise Program_Error with
339 "Position cursor designates wrong container";
343 (Vet (Container.Tree, Position.Node),
344 "bad cursor in Constant_Reference");
347 Tree : Tree_Type renames Position.Container.all.Tree;
348 TC : constant Tamper_Counts_Access :=
349 Tree.TC'Unrestricted_Access;
351 return R : constant Constant_Reference_Type :=
352 (Element => Position.Node.Element'Access,
353 Control => (Controlled with TC))
358 end Constant_Reference;
366 Item : Element_Type) return Boolean
369 return Find (Container, Item) /= No_Element;
376 function Copy (Source : Set) return Set is
378 return Target : Set do
379 Target.Assign (Source);
387 function Copy_Node (Source : Node_Access) return Node_Access is
388 Target : constant Node_Access :=
389 new Node_Type'(Parent
=> null,
392 Color
=> Source
.Color
,
393 Element
=> Source
.Element
);
402 procedure Delete
(Container
: in out Set
; Position
: in out Cursor
) is
404 if Checks
and then Position
.Node
= null then
405 raise Constraint_Error
with "Position cursor equals No_Element";
408 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
410 raise Program_Error
with "Position cursor designates wrong set";
413 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
414 "bad cursor in Delete");
416 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, Position
.Node
);
417 Free
(Position
.Node
);
418 Position
.Container
:= null;
421 procedure Delete
(Container
: in out Set
; Item
: Element_Type
) is
422 X
: Node_Access
:= Element_Keys
.Find
(Container
.Tree
, Item
);
425 if Checks
and then X
= null then
426 raise Constraint_Error
with "attempt to delete element not in set";
429 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
437 procedure Delete_First
(Container
: in out Set
) is
438 Tree
: Tree_Type
renames Container
.Tree
;
439 X
: Node_Access
:= Tree
.First
;
442 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
451 procedure Delete_Last
(Container
: in out Set
) is
452 Tree
: Tree_Type
renames Container
.Tree
;
453 X
: Node_Access
:= Tree
.Last
;
456 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
465 procedure Difference
(Target
: in out Set
; Source
: Set
) is
467 Set_Ops
.Difference
(Target
.Tree
, Source
.Tree
);
470 function Difference
(Left
, Right
: Set
) return Set
is
471 Tree
: constant Tree_Type
:= Set_Ops
.Difference
(Left
.Tree
, Right
.Tree
);
473 return Set
'(Controlled with Tree);
480 function Element (Position : Cursor) return Element_Type is
482 if Checks and then Position.Node = null then
483 raise Constraint_Error with "Position cursor equals No_Element";
487 and then (Left (Position.Node) = Position.Node
489 Right (Position.Node) = Position.Node)
491 raise Program_Error with "dangling cursor";
494 pragma Assert (Vet (Position.Container.Tree, Position.Node),
495 "bad cursor in Element");
497 return Position.Node.Element;
500 -------------------------
501 -- Equivalent_Elements --
502 -------------------------
504 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
506 return (if Left < Right or else Right < Left then False else True);
507 end Equivalent_Elements;
509 ---------------------
510 -- Equivalent_Sets --
511 ---------------------
513 function Equivalent_Sets (Left, Right : Set) return Boolean is
514 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
515 pragma Inline (Is_Equivalent_Node_Node);
517 function Is_Equivalent is
518 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
520 -----------------------------
521 -- Is_Equivalent_Node_Node --
522 -----------------------------
524 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
526 return (if L.Element < R.Element then False
527 elsif R.Element < L.Element then False
529 end Is_Equivalent_Node_Node;
531 -- Start of processing for Equivalent_Sets
534 return Is_Equivalent (Left.Tree, Right.Tree);
541 procedure Exclude (Container : in out Set; Item : Element_Type) is
542 X : Node_Access := Element_Keys.Find (Container.Tree, Item);
546 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
555 procedure Finalize (Object : in out Iterator) is
557 if Object.Container /= null then
558 Unbusy (Object.Container.Tree.TC);
566 function Find (Container : Set; Item : Element_Type) return Cursor is
567 Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item);
569 return (if Node = null then No_Element
570 else Cursor'(Container
'Unrestricted_Access, Node
));
577 function First
(Container
: Set
) return Cursor
is
580 (if Container
.Tree
.First
= null then No_Element
581 else Cursor
'(Container'Unrestricted_Access, Container.Tree.First));
584 function First (Object : Iterator) return Cursor is
586 -- The value of the iterator object's Node component influences the
587 -- behavior of the First (and Last) selector function.
589 -- When the Node component is null, this means the iterator object was
590 -- constructed without a start expression, in which case the (forward)
591 -- iteration starts from the (logical) beginning of the entire sequence
592 -- of items (corresponding to Container.First, for a forward iterator).
594 -- Otherwise, this is iteration over a partial sequence of items. When
595 -- the Node component is non-null, the iterator object was constructed
596 -- with a start expression, that specifies the position from which the
597 -- (forward) partial iteration begins.
599 if Object.Node = null then
600 return Object.Container.First;
602 return Cursor'(Object
.Container
, Object
.Node
);
610 function First_Element
(Container
: Set
) return Element_Type
is
612 if Checks
and then Container
.Tree
.First
= null then
613 raise Constraint_Error
with "set is empty";
616 return Container
.Tree
.First
.Element
;
623 function Floor
(Container
: Set
; Item
: Element_Type
) return Cursor
is
624 Node
: constant Node_Access
:= Element_Keys
.Floor
(Container
.Tree
, Item
);
626 return (if Node
= null then No_Element
627 else Cursor
'(Container'Unrestricted_Access, Node));
634 procedure Free (X : in out Node_Access) is
635 procedure Deallocate is
636 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
646 -- Ada 2022 features:
648 function Has_Element (Container : Set; Position : Cursor) return Boolean is
651 (Vet (Container.Tree, Position.Node), "bad cursor in Has_Element");
652 pragma Assert ((Position.Container = null) = (Position.Node = null),
653 "bad nullity in Has_Element");
654 return Position.Container = Container'Unrestricted_Access;
657 function Tampering_With_Cursors_Prohibited
658 (Container : Set) return Boolean
661 return Is_Busy (Container.Tree.TC);
662 end Tampering_With_Cursors_Prohibited;
664 function Element (Container : Set; Position : Cursor) return Element_Type is
666 if Checks and then not Has_Element (Container, Position) then
667 raise Program_Error with "Position for wrong Container";
670 return Element (Position);
673 procedure Query_Element
676 Process : not null access procedure (Element : Element_Type)) is
678 if Checks and then not Has_Element (Container, Position) then
679 raise Program_Error with "Position for wrong Container";
682 Query_Element (Position, Process);
685 function Next (Container : Set; Position : Cursor) return Cursor is
688 not (Position = No_Element or else Has_Element (Container, Position))
690 raise Program_Error with "Position for wrong Container";
693 return Next (Position);
696 procedure Next (Container : Set; Position : in out Cursor) is
698 Position := Next (Container, Position);
705 package body Generic_Keys is
707 -----------------------
708 -- Local Subprograms --
709 -----------------------
711 function Is_Greater_Key_Node
713 Right : Node_Access) return Boolean;
714 pragma Inline (Is_Greater_Key_Node);
716 function Is_Less_Key_Node
718 Right : Node_Access) return Boolean;
719 pragma Inline (Is_Less_Key_Node);
721 --------------------------
722 -- Local Instantiations --
723 --------------------------
726 new Red_Black_Trees.Generic_Keys
727 (Tree_Operations => Tree_Operations,
728 Key_Type => Key_Type,
729 Is_Less_Key_Node => Is_Less_Key_Node,
730 Is_Greater_Key_Node => Is_Greater_Key_Node);
736 procedure Adjust (Control : in out Reference_Control_Type) is
738 Impl.Reference_Control_Type (Control).Adjust;
739 if Control.Old_Key /= null then
740 Control.Old_Key := new Key_Type'(Control
.Old_Key
.all);
748 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
is
749 Node
: constant Node_Access
:= Key_Keys
.Ceiling
(Container
.Tree
, Key
);
751 return (if Node
= null then No_Element
752 else Cursor
'(Container'Unrestricted_Access, Node));
755 ------------------------
756 -- Constant_Reference --
757 ------------------------
759 function Constant_Reference
760 (Container : aliased Set;
761 Key : Key_Type) return Constant_Reference_Type
763 Position : constant Cursor := Find (Container, Key);
766 if Checks and then Position = No_Element then
767 raise Constraint_Error with "key not in set";
770 return Constant_Reference (Container, Position);
771 end Constant_Reference;
777 function Contains (Container : Set; Key : Key_Type) return Boolean is
779 return Find (Container, Key) /= No_Element;
786 procedure Delete (Container : in out Set; Key : Key_Type) is
787 X : Node_Access := Key_Keys.Find (Container.Tree, Key);
790 if Checks and then X = null then
791 raise Constraint_Error with "attempt to delete key not in set";
794 Delete_Node_Sans_Free (Container.Tree, X);
802 function Element (Container : Set; Key : Key_Type) return Element_Type is
803 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
806 if Checks and then Node = null then
807 raise Constraint_Error with "key not in set";
813 ---------------------
814 -- Equivalent_Keys --
815 ---------------------
817 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
819 return (if Left < Right or else Right < Left then False else True);
826 procedure Exclude (Container : in out Set; Key : Key_Type) is
827 X : Node_Access := Key_Keys.Find (Container.Tree, Key);
830 Delete_Node_Sans_Free (Container.Tree, X);
839 procedure Finalize (Control : in out Reference_Control_Type) is
840 procedure Deallocate is
841 new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
843 if Control.Container /= null then
844 Impl.Reference_Control_Type (Control).Finalize;
846 if Checks and then not (Key (Control.Pos) = Control.Old_Key.all)
848 Delete (Control.Container.all, Key (Control.Pos));
852 Control.Container := null;
853 Deallocate (Control.Old_Key);
861 function Find (Container : Set; Key : Key_Type) return Cursor is
862 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
864 return (if Node = null then No_Element
865 else Cursor'(Container
'Unrestricted_Access, Node
));
872 function Floor
(Container
: Set
; Key
: Key_Type
) return Cursor
is
873 Node
: constant Node_Access
:= Key_Keys
.Floor
(Container
.Tree
, Key
);
875 return (if Node
= null then No_Element
876 else Cursor
'(Container'Unrestricted_Access, Node));
879 -------------------------
880 -- Is_Greater_Key_Node --
881 -------------------------
883 function Is_Greater_Key_Node
885 Right : Node_Access) return Boolean
888 return Key (Right.Element) < Left;
889 end Is_Greater_Key_Node;
891 ----------------------
892 -- Is_Less_Key_Node --
893 ----------------------
895 function Is_Less_Key_Node
897 Right : Node_Access) return Boolean
900 return Left < Key (Right.Element);
901 end Is_Less_Key_Node;
907 function Key (Position : Cursor) return Key_Type is
909 if Checks and then Position.Node = null then
910 raise Constraint_Error with
911 "Position cursor equals No_Element";
914 pragma Assert (Vet (Position.Container.Tree, Position.Node),
915 "bad cursor in Key");
917 return Key (Position.Node.Element);
925 (Stream : not null access Root_Stream_Type'Class;
926 Item : out Reference_Type)
929 raise Program_Error with "attempt to stream reference";
932 ------------------------------
933 -- Reference_Preserving_Key --
934 ------------------------------
936 function Reference_Preserving_Key
937 (Container : aliased in out Set;
938 Position : Cursor) return Reference_Type
941 if Checks and then Position.Container = null then
942 raise Constraint_Error with "Position cursor has no element";
945 if Checks and then Position.Container /= Container'Unrestricted_Access
947 raise Program_Error with
948 "Position cursor designates wrong container";
952 (Vet (Container.Tree, Position.Node),
953 "bad cursor in function Reference_Preserving_Key");
956 Tree : Tree_Type renames Container.Tree;
958 return R : constant Reference_Type :=
959 (Element => Position.Node.Element'Access,
962 Tree.TC'Unrestricted_Access,
963 Container => Container'Unchecked_Access,
965 Old_Key => new Key_Type'(Key
(Position
))))
970 end Reference_Preserving_Key
;
972 function Reference_Preserving_Key
973 (Container
: aliased in out Set
;
974 Key
: Key_Type
) return Reference_Type
976 Position
: constant Cursor
:= Find
(Container
, Key
);
979 if Checks
and then Position
= No_Element
then
980 raise Constraint_Error
with "Key not in set";
983 return Reference_Preserving_Key
(Container
, Position
);
984 end Reference_Preserving_Key
;
991 (Container
: in out Set
;
993 New_Item
: Element_Type
)
995 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
998 if Checks
and then Node
= null then
999 raise Constraint_Error
with
1000 "attempt to replace key not in set";
1003 Replace_Element
(Container
.Tree
, Node
, New_Item
);
1006 -----------------------------------
1007 -- Update_Element_Preserving_Key --
1008 -----------------------------------
1010 procedure Update_Element_Preserving_Key
1011 (Container
: in out Set
;
1013 Process
: not null access procedure (Element
: in out Element_Type
))
1015 Tree
: Tree_Type
renames Container
.Tree
;
1018 if Checks
and then Position
.Node
= null then
1019 raise Constraint_Error
with
1020 "Position cursor equals No_Element";
1023 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
1025 raise Program_Error
with
1026 "Position cursor designates wrong set";
1029 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
1030 "bad cursor in Update_Element_Preserving_Key");
1033 E
: Element_Type
renames Position
.Node
.Element
;
1034 K
: constant Key_Type
:= Key
(E
);
1035 Lock
: With_Lock
(Tree
.TC
'Unrestricted_Access);
1038 if Equivalent_Keys
(K
, Key
(E
)) then
1044 X
: Node_Access
:= Position
.Node
;
1046 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
1050 raise Program_Error
with "key was modified";
1051 end Update_Element_Preserving_Key
;
1058 (Stream
: not null access Root_Stream_Type
'Class;
1059 Item
: Reference_Type
)
1062 raise Program_Error
with "attempt to stream reference";
1067 ------------------------
1068 -- Get_Element_Access --
1069 ------------------------
1071 function Get_Element_Access
1072 (Position
: Cursor
) return not null Element_Access
is
1074 return Position
.Node
.Element
'Access;
1075 end Get_Element_Access
;
1081 function Has_Element
(Position
: Cursor
) return Boolean is
1083 return Position
/= No_Element
;
1090 procedure Include
(Container
: in out Set
; New_Item
: Element_Type
) is
1095 Insert
(Container
, New_Item
, Position
, Inserted
);
1097 if not Inserted
then
1098 TE_Check
(Container
.Tree
.TC
);
1100 Position
.Node
.Element
:= New_Item
;
1109 (Container
: in out Set
;
1110 New_Item
: Element_Type
;
1111 Position
: out Cursor
;
1112 Inserted
: out Boolean)
1121 Position
.Container
:= Container
'Unrestricted_Access;
1125 (Container
: in out Set
;
1126 New_Item
: Element_Type
)
1132 Insert
(Container
, New_Item
, Position
, Inserted
);
1134 if Checks
and then not Inserted
then
1135 raise Constraint_Error
with
1136 "attempt to insert element already in set";
1140 ----------------------
1141 -- Insert_Sans_Hint --
1142 ----------------------
1144 procedure Insert_Sans_Hint
1145 (Tree
: in out Tree_Type
;
1146 New_Item
: Element_Type
;
1147 Node
: out Node_Access
;
1148 Inserted
: out Boolean)
1150 function New_Node
return Node_Access
;
1151 pragma Inline
(New_Node
);
1153 procedure Insert_Post
is
1154 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1156 procedure Conditional_Insert_Sans_Hint
is
1157 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
1163 function New_Node
return Node_Access
is
1165 return new Node_Type
'(Parent => null,
1168 Color => Red_Black_Trees.Red,
1169 Element => New_Item);
1172 -- Start of processing for Insert_Sans_Hint
1175 Conditional_Insert_Sans_Hint
1180 end Insert_Sans_Hint;
1182 ----------------------
1183 -- Insert_With_Hint --
1184 ----------------------
1186 procedure Insert_With_Hint
1187 (Dst_Tree : in out Tree_Type;
1188 Dst_Hint : Node_Access;
1189 Src_Node : Node_Access;
1190 Dst_Node : out Node_Access)
1194 function New_Node return Node_Access;
1195 pragma Inline (New_Node);
1197 procedure Insert_Post is
1198 new Element_Keys.Generic_Insert_Post (New_Node);
1200 procedure Insert_Sans_Hint is
1201 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1203 procedure Local_Insert_With_Hint is
1204 new Element_Keys.Generic_Conditional_Insert_With_Hint
1212 function New_Node return Node_Access is
1213 Node : constant Node_Access :=
1214 new Node_Type'(Parent
=> null,
1218 Element
=> Src_Node
.Element
);
1223 -- Start of processing for Insert_With_Hint
1226 Local_Insert_With_Hint
1232 end Insert_With_Hint
;
1238 procedure Intersection
(Target
: in out Set
; Source
: Set
) is
1240 Set_Ops
.Intersection
(Target
.Tree
, Source
.Tree
);
1243 function Intersection
(Left
, Right
: Set
) return Set
is
1244 Tree
: constant Tree_Type
:=
1245 Set_Ops
.Intersection
(Left
.Tree
, Right
.Tree
);
1247 return Set
'(Controlled with Tree);
1254 function Is_Empty (Container : Set) return Boolean is
1256 return Container.Tree.Length = 0;
1259 ------------------------
1260 -- Is_Equal_Node_Node --
1261 ------------------------
1263 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1265 return L.Element = R.Element;
1266 end Is_Equal_Node_Node;
1268 -----------------------------
1269 -- Is_Greater_Element_Node --
1270 -----------------------------
1272 function Is_Greater_Element_Node
1273 (Left : Element_Type;
1274 Right : Node_Access) return Boolean
1277 -- Compute e > node same as node < e
1279 return Right.Element < Left;
1280 end Is_Greater_Element_Node;
1282 --------------------------
1283 -- Is_Less_Element_Node --
1284 --------------------------
1286 function Is_Less_Element_Node
1287 (Left : Element_Type;
1288 Right : Node_Access) return Boolean
1291 return Left < Right.Element;
1292 end Is_Less_Element_Node;
1294 -----------------------
1295 -- Is_Less_Node_Node --
1296 -----------------------
1298 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1300 return L.Element < R.Element;
1301 end Is_Less_Node_Node;
1307 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1309 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1318 Process : not null access procedure (Position : Cursor))
1320 procedure Process_Node (Node : Node_Access);
1321 pragma Inline (Process_Node);
1323 procedure Local_Iterate is
1324 new Tree_Operations.Generic_Iteration (Process_Node);
1330 procedure Process_Node (Node : Node_Access) is
1332 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1335 T
: Tree_Type
renames Container
'Unrestricted_Access.all.Tree
;
1336 Busy
: With_Busy
(T
.TC
'Unrestricted_Access);
1338 -- Start of processing for Iterate
1344 function Iterate
(Container
: Set
)
1345 return Set_Iterator_Interfaces
.Reversible_Iterator
'Class
1348 -- The value of the Node component influences the behavior of the First
1349 -- and Last selector functions of the iterator object. When the Node
1350 -- component is null (as is the case here), this means the iterator
1351 -- object was constructed without a start expression. This is a complete
1352 -- iterator, meaning that the iteration starts from the (logical)
1353 -- beginning of the sequence of items.
1355 -- Note: For a forward iterator, Container.First is the beginning, and
1356 -- for a reverse iterator, Container.Last is the beginning.
1358 Busy
(Container
.Tree
.TC
'Unrestricted_Access.all);
1360 return It
: constant Iterator
:=
1361 Iterator
'(Limited_Controlled with
1362 Container => Container'Unrestricted_Access,
1366 function Iterate (Container : Set; Start : Cursor)
1367 return Set_Iterator_Interfaces.Reversible_Iterator'Class
1370 -- It was formerly the case that when Start = No_Element, the partial
1371 -- iterator was defined to behave the same as for a complete iterator,
1372 -- and iterate over the entire sequence of items. However, those
1373 -- semantics were unintuitive and arguably error-prone (it is too easy
1374 -- to accidentally create an endless loop), and so they were changed,
1375 -- per the ARG meeting in Denver on 2011/11. However, there was no
1376 -- consensus about what positive meaning this corner case should have,
1377 -- and so it was decided to simply raise an exception. This does imply,
1378 -- however, that it is not possible to use a partial iterator to specify
1379 -- an empty sequence of items.
1381 if Checks and then Start = No_Element then
1382 raise Constraint_Error with
1383 "Start position for iterator equals No_Element";
1386 if Checks and then Start.Container /= Container'Unrestricted_Access then
1387 raise Program_Error with
1388 "Start cursor of Iterate designates wrong set";
1391 pragma Assert (Vet (Container.Tree, Start.Node),
1392 "Start cursor of Iterate is bad");
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 non-null (as is the case here), it means that this is a
1397 -- partial iteration, over a subset of the complete sequence of
1398 -- items. The iterator object was constructed with a start expression,
1399 -- indicating the position from which the iteration begins. Note that
1400 -- the start position has the same value irrespective of whether this is
1401 -- a forward or reverse iteration.
1403 Busy (Container.Tree.TC'Unrestricted_Access.all);
1405 return It : constant Iterator :=
1406 Iterator'(Limited_Controlled
with
1407 Container
=> Container
'Unrestricted_Access,
1408 Node
=> Start
.Node
);
1415 function Last
(Container
: Set
) return Cursor
is
1418 (if Container
.Tree
.Last
= null then No_Element
1419 else Cursor
'(Container'Unrestricted_Access, Container.Tree.Last));
1422 function Last (Object : Iterator) return Cursor is
1424 -- The value of the iterator object's Node component influences the
1425 -- behavior of the Last (and First) selector function.
1427 -- When the Node component is null, this means the iterator object was
1428 -- constructed without a start expression, in which case the (reverse)
1429 -- iteration starts from the (logical) beginning of the entire sequence
1430 -- (corresponding to Container.Last, for a reverse iterator).
1432 -- Otherwise, this is iteration over a partial sequence of items. When
1433 -- the Node component is non-null, the iterator object was constructed
1434 -- with a start expression, that specifies the position from which the
1435 -- (reverse) partial iteration begins.
1437 if Object.Node = null then
1438 return Object.Container.Last;
1440 return Cursor'(Object
.Container
, Object
.Node
);
1448 function Last_Element
(Container
: Set
) return Element_Type
is
1450 if Checks
and then Container
.Tree
.Last
= null then
1451 raise Constraint_Error
with "set is empty";
1454 return Container
.Tree
.Last
.Element
;
1461 function Left
(Node
: Node_Access
) return Node_Access
is
1470 function Length
(Container
: Set
) return Count_Type
is
1472 return Container
.Tree
.Length
;
1479 procedure Move
is new Tree_Operations
.Generic_Move
(Clear
);
1481 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1483 Move
(Target
=> Target
.Tree
, Source
=> Source
.Tree
);
1490 function Next
(Position
: Cursor
) return Cursor
is
1492 if Position
= No_Element
then
1496 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1497 "bad cursor in Next");
1500 Node
: constant Node_Access
:=
1501 Tree_Operations
.Next
(Position
.Node
);
1503 return (if Node
= null then No_Element
1504 else Cursor
'(Position.Container, Node));
1508 procedure Next (Position : in out Cursor) is
1510 Position := Next (Position);
1513 function Next (Object : Iterator; Position : Cursor) return Cursor is
1515 if Position.Container = null then
1519 if Checks and then Position.Container /= Object.Container then
1520 raise Program_Error with
1521 "Position cursor of Next designates wrong set";
1524 return Next (Position);
1531 function Overlap (Left, Right : Set) return Boolean is
1533 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1540 function Parent (Node : Node_Access) return Node_Access is
1549 function Previous (Position : Cursor) return Cursor is
1551 if Position = No_Element then
1555 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1556 "bad cursor in Previous");
1559 Node : constant Node_Access :=
1560 Tree_Operations.Previous (Position.Node);
1562 return (if Node = null then No_Element
1563 else Cursor'(Position
.Container
, Node
));
1567 procedure Previous
(Position
: in out Cursor
) is
1569 Position
:= Previous
(Position
);
1572 function Previous
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
1574 if Position
.Container
= null then
1578 if Checks
and then Position
.Container
/= Object
.Container
then
1579 raise Program_Error
with
1580 "Position cursor of Previous designates wrong set";
1583 return Previous
(Position
);
1586 ----------------------
1587 -- Pseudo_Reference --
1588 ----------------------
1590 function Pseudo_Reference
1591 (Container
: aliased Set
'Class) return Reference_Control_Type
1593 TC
: constant Tamper_Counts_Access
:=
1594 Container
.Tree
.TC
'Unrestricted_Access;
1596 return R
: constant Reference_Control_Type
:= (Controlled
with TC
) do
1599 end Pseudo_Reference
;
1605 procedure Query_Element
1607 Process
: not null access procedure (Element
: Element_Type
))
1610 if Checks
and then Position
.Node
= null then
1611 raise Constraint_Error
with "Position cursor equals No_Element";
1614 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1615 "bad cursor in Query_Element");
1618 T
: Tree_Type
renames Position
.Container
.Tree
;
1619 Lock
: With_Lock
(T
.TC
'Unrestricted_Access);
1621 Process
(Position
.Node
.Element
);
1630 (S
: in out Ada
.Strings
.Text_Buffers
.Root_Buffer_Type
'Class; V
: Set
)
1632 First_Time
: Boolean := True;
1633 use System
.Put_Images
;
1639 First_Time
:= False;
1641 Simple_Array_Between
(S
);
1644 Element_Type
'Put_Image (S
, X
);
1655 (Stream
: not null access Root_Stream_Type
'Class;
1656 Container
: out Set
)
1659 (Stream
: not null access Root_Stream_Type
'Class) return Node_Access
;
1660 pragma Inline
(Read_Node
);
1663 new Tree_Operations
.Generic_Read
(Clear
, Read_Node
);
1670 (Stream
: not null access Root_Stream_Type
'Class) return Node_Access
1672 Node
: Node_Access
:= new Node_Type
;
1674 Element_Type
'Read (Stream
, Node
.Element
);
1682 -- Start of processing for Read
1685 Read
(Stream
, Container
.Tree
);
1689 (Stream
: not null access Root_Stream_Type
'Class;
1693 raise Program_Error
with "attempt to stream set cursor";
1697 (Stream
: not null access Root_Stream_Type
'Class;
1698 Item
: out Constant_Reference_Type
)
1701 raise Program_Error
with "attempt to stream reference";
1708 procedure Replace
(Container
: in out Set
; New_Item
: Element_Type
) is
1709 Node
: constant Node_Access
:=
1710 Element_Keys
.Find
(Container
.Tree
, New_Item
);
1713 TE_Check
(Container
.Tree
.TC
);
1715 if Checks
and then Node
= null then
1716 raise Constraint_Error
with
1717 "attempt to replace element not in set";
1720 Node
.Element
:= New_Item
;
1723 ---------------------
1724 -- Replace_Element --
1725 ---------------------
1727 procedure Replace_Element
1728 (Tree
: in out Tree_Type
;
1730 Item
: Element_Type
)
1732 pragma Assert
(Node
/= null);
1734 function New_Node
return Node_Access
;
1735 pragma Inline
(New_Node
);
1737 procedure Local_Insert_Post
is
1738 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1740 procedure Local_Insert_Sans_Hint
is
1741 new Element_Keys
.Generic_Conditional_Insert
(Local_Insert_Post
);
1743 procedure Local_Insert_With_Hint
is
1744 new Element_Keys
.Generic_Conditional_Insert_With_Hint
1746 Local_Insert_Sans_Hint
);
1752 function New_Node
return Node_Access
is
1754 Node
.Element
:= Item
;
1756 Node
.Parent
:= null;
1763 Result
: Node_Access
;
1767 -- Start of processing for Replace_Element
1770 -- Replace_Element assigns value Item to the element designated by Node,
1771 -- per certain semantic constraints.
1773 -- If Item is equivalent to the element, then element is replaced and
1774 -- there's nothing else to do. This is the easy case.
1776 -- If Item is not equivalent, then the node will (possibly) have to move
1777 -- to some other place in the tree. This is slighly more complicated,
1778 -- because we must ensure that Item is not equivalent to some other
1779 -- element in the tree (in which case, the replacement is not allowed).
1781 -- Determine whether Item is equivalent to element on the specified
1785 Lock
: With_Lock
(Tree
.TC
'Unrestricted_Access);
1787 Compare
:= (if Item
< Node
.Element
then False
1788 elsif Node
.Element
< Item
then False
1793 -- Item is equivalent to the node's element, so we will not have to
1798 Node
.Element
:= Item
;
1802 -- The replacement Item is not equivalent to the element on the
1803 -- specified node, which means that it will need to be re-inserted in a
1804 -- different position in the tree. We must now determine whether Item is
1805 -- equivalent to some other element in the tree (which would prohibit
1806 -- the assignment and hence the move).
1808 -- Ceiling returns the smallest element equivalent or greater than the
1809 -- specified Item; if there is no such element, then it returns null.
1811 Hint
:= Element_Keys
.Ceiling
(Tree
, Item
);
1813 if Hint
/= null then
1815 Lock
: With_Lock
(Tree
.TC
'Unrestricted_Access);
1817 Compare
:= Item
< Hint
.Element
;
1820 -- Item >= Hint.Element
1822 if Checks
and then not Compare
then
1824 -- Ceiling returns an element that is equivalent or greater
1825 -- than Item. If Item is "not less than" the element, then
1826 -- by elimination we know that Item is equivalent to the element.
1828 -- But this means that it is not possible to assign the value of
1829 -- Item to the specified element (on Node), because a different
1830 -- element (on Hint) equivalent to Item already exsits. (Were we
1831 -- to change Node's element value, we would have to move Node, but
1832 -- we would be unable to move the Node, because its new position
1833 -- in the tree is already occupied by an equivalent element.)
1835 raise Program_Error
with "attempt to replace existing element";
1838 -- Item is not equivalent to any other element in the tree, so it is
1839 -- safe to assign the value of Item to Node.Element. This means that
1840 -- the node will have to move to a different position in the tree
1841 -- (because its element will have a different value).
1843 -- The nearest (greater) neighbor of Item is Hint. This will be the
1844 -- insertion position of Node (because its element will have Item as
1847 -- If Node equals Hint, the relative position of Node does not
1848 -- change. This allows us to perform an optimization: we need not
1849 -- remove Node from the tree and then reinsert it with its new value,
1850 -- because it would only be placed in the exact same position.
1855 Node
.Element
:= Item
;
1860 -- If we get here, it is because Item was greater than all elements in
1861 -- the tree (Hint = null), or because Item was less than some element at
1862 -- a different place in the tree (Item < Hint.Element). In either case,
1863 -- we remove Node from the tree (without actually deallocating it), and
1864 -- then insert Item into the tree, onto the same Node (so no new node is
1865 -- actually allocated).
1867 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Node
); -- Checks busy-bit
1869 Local_Insert_With_Hint
-- use unconditional insert here instead???
1874 Inserted
=> Inserted
);
1876 pragma Assert
(Inserted
);
1877 pragma Assert
(Result
= Node
);
1878 end Replace_Element
;
1880 procedure Replace_Element
1881 (Container
: in out Set
;
1883 New_Item
: Element_Type
)
1886 if Checks
and then Position
.Node
= null then
1887 raise Constraint_Error
with
1888 "Position cursor equals No_Element";
1891 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
1893 raise Program_Error
with
1894 "Position cursor designates wrong set";
1897 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
1898 "bad cursor in Replace_Element");
1900 Replace_Element
(Container
.Tree
, Position
.Node
, New_Item
);
1901 end Replace_Element
;
1903 ---------------------
1904 -- Reverse_Iterate --
1905 ---------------------
1907 procedure Reverse_Iterate
1909 Process
: not null access procedure (Position
: Cursor
))
1911 procedure Process_Node
(Node
: Node_Access
);
1912 pragma Inline
(Process_Node
);
1914 procedure Local_Reverse_Iterate
is
1915 new Tree_Operations
.Generic_Reverse_Iteration
(Process_Node
);
1921 procedure Process_Node
(Node
: Node_Access
) is
1923 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1926 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1927 Busy : With_Busy (T.TC'Unrestricted_Access);
1929 -- Start of processing for Reverse_Iterate
1932 Local_Reverse_Iterate (T);
1933 end Reverse_Iterate;
1939 function Right (Node : Node_Access) return Node_Access is
1948 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1950 Node.Color := Color;
1957 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1966 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1968 Node.Parent := Parent;
1975 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1977 Node.Right := Right;
1980 --------------------------
1981 -- Symmetric_Difference --
1982 --------------------------
1984 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1986 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1987 end Symmetric_Difference;
1989 function Symmetric_Difference (Left, Right : Set) return Set is
1990 Tree : constant Tree_Type :=
1991 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1993 return Set'(Controlled
with Tree
);
1994 end Symmetric_Difference
;
2000 function To_Set
(New_Item
: Element_Type
) return Set
is
2005 Insert_Sans_Hint
(Tree
, New_Item
, Node
, Inserted
);
2006 return Set
'(Controlled with Tree);
2013 procedure Union (Target : in out Set; Source : Set) is
2015 Set_Ops.Union (Target.Tree, Source.Tree);
2018 function Union (Left, Right : Set) return Set is
2019 Tree : constant Tree_Type :=
2020 Set_Ops.Union (Left.Tree, Right.Tree);
2022 return Set'(Controlled
with Tree
);
2030 (Stream
: not null access Root_Stream_Type
'Class;
2033 procedure Write_Node
2034 (Stream
: not null access Root_Stream_Type
'Class;
2035 Node
: Node_Access
);
2036 pragma Inline
(Write_Node
);
2039 new Tree_Operations
.Generic_Write
(Write_Node
);
2045 procedure Write_Node
2046 (Stream
: not null access Root_Stream_Type
'Class;
2050 Element_Type
'Write (Stream
, Node
.Element
);
2053 -- Start of processing for Write
2056 Write
(Stream
, Container
.Tree
);
2060 (Stream
: not null access Root_Stream_Type
'Class;
2064 raise Program_Error
with "attempt to stream set cursor";
2068 (Stream
: not null access Root_Stream_Type
'Class;
2069 Item
: Constant_Reference_Type
)
2072 raise Program_Error
with "attempt to stream reference";
2075 end Ada
.Containers
.Ordered_Sets
;