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-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
.Unchecked_Deallocation
;
32 with Ada
.Containers
.Red_Black_Trees
.Generic_Operations
;
33 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Operations
);
35 with Ada
.Containers
.Red_Black_Trees
.Generic_Keys
;
36 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Keys
);
38 with Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
;
39 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
);
41 with System
; use type System
.Address
;
43 package body Ada
.Containers
.Ordered_Sets
is
45 ------------------------------
46 -- Access to Fields of Node --
47 ------------------------------
49 -- These subprograms provide functional notation for access to fields
50 -- of a node, and procedural notation for modifying these fields.
52 function Color
(Node
: Node_Access
) return Color_Type
;
53 pragma Inline
(Color
);
55 function Left
(Node
: Node_Access
) return Node_Access
;
58 function Parent
(Node
: Node_Access
) return Node_Access
;
59 pragma Inline
(Parent
);
61 function Right
(Node
: Node_Access
) return Node_Access
;
62 pragma Inline
(Right
);
64 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
65 pragma Inline
(Set_Color
);
67 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
68 pragma Inline
(Set_Left
);
70 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
71 pragma Inline
(Set_Right
);
73 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
74 pragma Inline
(Set_Parent
);
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
81 pragma Inline
(Copy_Node
);
83 procedure Free
(X
: in out Node_Access
);
85 procedure Insert_Sans_Hint
86 (Tree
: in out Tree_Type
;
87 New_Item
: Element_Type
;
88 Node
: out Node_Access
;
89 Inserted
: out Boolean);
91 procedure Insert_With_Hint
92 (Dst_Tree
: in out Tree_Type
;
93 Dst_Hint
: Node_Access
;
94 Src_Node
: Node_Access
;
95 Dst_Node
: out Node_Access
);
97 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean;
98 pragma Inline
(Is_Equal_Node_Node
);
100 function Is_Greater_Element_Node
101 (Left
: Element_Type
;
102 Right
: Node_Access
) return Boolean;
103 pragma Inline
(Is_Greater_Element_Node
);
105 function Is_Less_Element_Node
106 (Left
: Element_Type
;
107 Right
: Node_Access
) return Boolean;
108 pragma Inline
(Is_Less_Element_Node
);
110 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean;
111 pragma Inline
(Is_Less_Node_Node
);
113 procedure Replace_Element
114 (Tree
: in out Tree_Type
;
116 Item
: Element_Type
);
118 --------------------------
119 -- Local Instantiations --
120 --------------------------
122 package Tree_Operations
is
123 new Red_Black_Trees
.Generic_Operations
(Tree_Types
);
125 procedure Delete_Tree
is
126 new Tree_Operations
.Generic_Delete_Tree
(Free
);
128 function Copy_Tree
is
129 new Tree_Operations
.Generic_Copy_Tree
(Copy_Node
, Delete_Tree
);
134 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
136 package Element_Keys
is
137 new Red_Black_Trees
.Generic_Keys
138 (Tree_Operations
=> Tree_Operations
,
139 Key_Type
=> Element_Type
,
140 Is_Less_Key_Node
=> Is_Less_Element_Node
,
141 Is_Greater_Key_Node
=> Is_Greater_Element_Node
);
144 new Generic_Set_Operations
145 (Tree_Operations
=> Tree_Operations
,
146 Insert_With_Hint
=> Insert_With_Hint
,
147 Copy_Tree
=> Copy_Tree
,
148 Delete_Tree
=> Delete_Tree
,
149 Is_Less
=> Is_Less_Node_Node
,
156 function "<" (Left
, Right
: Cursor
) return Boolean is
158 if Left
.Node
= null then
159 raise Constraint_Error
with "Left cursor equals No_Element";
162 if Right
.Node
= null then
163 raise Constraint_Error
with "Right cursor equals No_Element";
166 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
167 "bad Left cursor in ""<""");
169 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
170 "bad Right cursor in ""<""");
172 return Left
.Node
.Element
< Right
.Node
.Element
;
175 function "<" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
177 if Left
.Node
= null then
178 raise Constraint_Error
with "Left cursor equals No_Element";
181 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
182 "bad Left cursor in ""<""");
184 return Left
.Node
.Element
< Right
;
187 function "<" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
189 if Right
.Node
= null then
190 raise Constraint_Error
with "Right cursor equals No_Element";
193 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
194 "bad Right cursor in ""<""");
196 return Left
< Right
.Node
.Element
;
203 function "=" (Left
, Right
: Set
) return Boolean is
205 return Is_Equal
(Left
.Tree
, Right
.Tree
);
212 function ">" (Left
, Right
: Cursor
) return Boolean is
214 if Left
.Node
= null then
215 raise Constraint_Error
with "Left cursor equals No_Element";
218 if Right
.Node
= null then
219 raise Constraint_Error
with "Right cursor equals No_Element";
222 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
223 "bad Left cursor in "">""");
225 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
226 "bad Right cursor in "">""");
228 -- L > R same as R < L
230 return Right
.Node
.Element
< Left
.Node
.Element
;
233 function ">" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
235 if Right
.Node
= null then
236 raise Constraint_Error
with "Right cursor equals No_Element";
239 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
240 "bad Right cursor in "">""");
242 return Right
.Node
.Element
< Left
;
245 function ">" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
247 if Left
.Node
= null then
248 raise Constraint_Error
with "Left cursor equals No_Element";
251 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
252 "bad Left cursor in "">""");
254 return Right
< Left
.Node
.Element
;
261 procedure Adjust
is new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
263 procedure Adjust
(Container
: in out Set
) is
265 Adjust
(Container
.Tree
);
268 procedure Adjust
(Control
: in out Reference_Control_Type
) is
270 if Control
.Container
/= null then
272 Tree
: Tree_Type
renames Control
.Container
.all.Tree
;
273 B
: Natural renames Tree
.Busy
;
274 L
: Natural renames Tree
.Lock
;
286 procedure Assign
(Target
: in out Set
; Source
: Set
) is
288 if Target
'Address = Source
'Address then
293 Target
.Union
(Source
);
300 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
is
301 Node
: constant Node_Access
:=
302 Element_Keys
.Ceiling
(Container
.Tree
, Item
);
304 return (if Node
= null then No_Element
305 else Cursor
'(Container'Unrestricted_Access, Node));
312 procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree);
314 procedure Clear (Container : in out Set) is
316 Clear (Container.Tree);
323 function Color (Node : Node_Access) return Color_Type is
328 ------------------------
329 -- Constant_Reference --
330 ------------------------
332 function Constant_Reference
333 (Container : aliased Set;
334 Position : Cursor) return Constant_Reference_Type
337 if Position.Container = null then
338 raise Constraint_Error with "Position cursor has no element";
341 if Position.Container /= Container'Unrestricted_Access then
342 raise Program_Error with
343 "Position cursor designates wrong container";
347 (Vet (Container.Tree, Position.Node),
348 "bad cursor in Constant_Reference");
351 Tree : Tree_Type renames Position.Container.all.Tree;
352 B : Natural renames Tree.Busy;
353 L : Natural renames Tree.Lock;
355 return R : constant Constant_Reference_Type :=
356 (Element => Position.Node.Element'Access,
357 Control => (Controlled with Container'Unrestricted_Access))
363 end Constant_Reference;
371 Item : Element_Type) return Boolean
374 return Find (Container, Item) /= No_Element;
381 function Copy (Source : Set) return Set is
383 return Target : Set do
384 Target.Assign (Source);
392 function Copy_Node (Source : Node_Access) return Node_Access is
393 Target : constant Node_Access :=
394 new Node_Type'(Parent
=> null,
397 Color
=> Source
.Color
,
398 Element
=> Source
.Element
);
407 procedure Delete
(Container
: in out Set
; Position
: in out Cursor
) is
409 if Position
.Node
= null then
410 raise Constraint_Error
with "Position cursor equals No_Element";
413 if Position
.Container
/= Container
'Unrestricted_Access then
414 raise Program_Error
with "Position cursor designates wrong set";
417 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
418 "bad cursor in Delete");
420 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, Position
.Node
);
421 Free
(Position
.Node
);
422 Position
.Container
:= null;
425 procedure Delete
(Container
: in out Set
; Item
: Element_Type
) is
426 X
: Node_Access
:= Element_Keys
.Find
(Container
.Tree
, Item
);
430 raise Constraint_Error
with "attempt to delete element not in set";
433 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
441 procedure Delete_First
(Container
: in out Set
) is
442 Tree
: Tree_Type
renames Container
.Tree
;
443 X
: Node_Access
:= Tree
.First
;
446 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
455 procedure Delete_Last
(Container
: in out Set
) is
456 Tree
: Tree_Type
renames Container
.Tree
;
457 X
: Node_Access
:= Tree
.Last
;
460 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
469 procedure Difference
(Target
: in out Set
; Source
: Set
) is
471 Set_Ops
.Difference
(Target
.Tree
, Source
.Tree
);
474 function Difference
(Left
, Right
: Set
) return Set
is
475 Tree
: constant Tree_Type
:= Set_Ops
.Difference
(Left
.Tree
, Right
.Tree
);
477 return Set
'(Controlled with Tree);
484 function Element (Position : Cursor) return Element_Type is
486 if Position.Node = null then
487 raise Constraint_Error with "Position cursor equals No_Element";
490 pragma Assert (Vet (Position.Container.Tree, Position.Node),
491 "bad cursor in Element");
493 return Position.Node.Element;
496 -------------------------
497 -- Equivalent_Elements --
498 -------------------------
500 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
502 return (if Left < Right or else Right < Left then False else True);
503 end Equivalent_Elements;
505 ---------------------
506 -- Equivalent_Sets --
507 ---------------------
509 function Equivalent_Sets (Left, Right : Set) return Boolean is
510 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
511 pragma Inline (Is_Equivalent_Node_Node);
513 function Is_Equivalent is
514 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
516 -----------------------------
517 -- Is_Equivalent_Node_Node --
518 -----------------------------
520 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
522 return (if L.Element < R.Element then False
523 elsif R.Element < L.Element then False
525 end Is_Equivalent_Node_Node;
527 -- Start of processing for Equivalent_Sets
530 return Is_Equivalent (Left.Tree, Right.Tree);
537 procedure Exclude (Container : in out Set; Item : Element_Type) is
538 X : Node_Access := Element_Keys.Find (Container.Tree, Item);
542 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
551 procedure Finalize (Object : in out Iterator) is
553 if Object.Container /= null then
555 B : Natural renames Object.Container.all.Tree.Busy;
562 procedure Finalize (Control : in out Reference_Control_Type) is
564 if Control.Container /= null then
566 Tree : Tree_Type renames Control.Container.all.Tree;
567 B : Natural renames Tree.Busy;
568 L : Natural renames Tree.Lock;
574 Control.Container := null;
582 function Find (Container : Set; Item : Element_Type) return Cursor is
583 Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item);
585 return (if Node = null then No_Element
586 else Cursor'(Container
'Unrestricted_Access, Node
));
593 function First
(Container
: Set
) return Cursor
is
596 (if Container
.Tree
.First
= null then No_Element
597 else Cursor
'(Container'Unrestricted_Access, Container.Tree.First));
600 function First (Object : Iterator) return Cursor is
602 -- The value of the iterator object's Node component influences the
603 -- behavior of the First (and Last) selector function.
605 -- When the Node component is null, this means the iterator object was
606 -- constructed without a start expression, in which case the (forward)
607 -- iteration starts from the (logical) beginning of the entire sequence
608 -- of items (corresponding to Container.First, for a forward iterator).
610 -- Otherwise, this is iteration over a partial sequence of items. When
611 -- the Node component is non-null, the iterator object was constructed
612 -- with a start expression, that specifies the position from which the
613 -- (forward) partial iteration begins.
615 if Object.Node = null then
616 return Object.Container.First;
618 return Cursor'(Object
.Container
, Object
.Node
);
626 function First_Element
(Container
: Set
) return Element_Type
is
628 if Container
.Tree
.First
= null then
629 raise Constraint_Error
with "set is empty";
632 return Container
.Tree
.First
.Element
;
639 function Floor
(Container
: Set
; Item
: Element_Type
) return Cursor
is
640 Node
: constant Node_Access
:= Element_Keys
.Floor
(Container
.Tree
, Item
);
642 return (if Node
= null then No_Element
643 else Cursor
'(Container'Unrestricted_Access, Node));
650 procedure Free (X : in out Node_Access) is
651 procedure Deallocate is
652 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
666 package body Generic_Keys is
668 -----------------------
669 -- Local Subprograms --
670 -----------------------
672 function Is_Greater_Key_Node
674 Right : Node_Access) return Boolean;
675 pragma Inline (Is_Greater_Key_Node);
677 function Is_Less_Key_Node
679 Right : Node_Access) return Boolean;
680 pragma Inline (Is_Less_Key_Node);
682 --------------------------
683 -- Local Instantiations --
684 --------------------------
687 new Red_Black_Trees.Generic_Keys
688 (Tree_Operations => Tree_Operations,
689 Key_Type => Key_Type,
690 Is_Less_Key_Node => Is_Less_Key_Node,
691 Is_Greater_Key_Node => Is_Greater_Key_Node);
697 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
698 Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key);
700 return (if Node = null then No_Element
701 else Cursor'(Container
'Unrestricted_Access, Node
));
704 ------------------------
705 -- Constant_Reference --
706 ------------------------
708 function Constant_Reference
709 (Container
: aliased Set
;
710 Key
: Key_Type
) return Constant_Reference_Type
712 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
716 raise Constraint_Error
with "key not in set";
720 Tree
: Tree_Type
renames Container
'Unrestricted_Access.all.Tree
;
721 B
: Natural renames Tree
.Busy
;
722 L
: Natural renames Tree
.Lock
;
724 return R
: constant Constant_Reference_Type
:=
725 (Element
=> Node
.Element
'Access,
726 Control
=> (Controlled
with Container
'Unrestricted_Access))
732 end Constant_Reference
;
738 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean is
740 return Find
(Container
, Key
) /= No_Element
;
747 procedure Delete
(Container
: in out Set
; Key
: Key_Type
) is
748 X
: Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
752 raise Constraint_Error
with "attempt to delete key not in set";
755 Delete_Node_Sans_Free
(Container
.Tree
, X
);
763 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
is
764 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
768 raise Constraint_Error
with "key not in set";
774 ---------------------
775 -- Equivalent_Keys --
776 ---------------------
778 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
780 return (if Left
< Right
or else Right
< Left
then False else True);
787 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
) is
788 X
: Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
791 Delete_Node_Sans_Free
(Container
.Tree
, X
);
800 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
is
801 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
803 return (if Node
= null then No_Element
804 else Cursor
'(Container'Unrestricted_Access, Node));
811 function Floor (Container : Set; Key : Key_Type) return Cursor is
812 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
814 return (if Node = null then No_Element
815 else Cursor'(Container
'Unrestricted_Access, Node
));
818 -------------------------
819 -- Is_Greater_Key_Node --
820 -------------------------
822 function Is_Greater_Key_Node
824 Right
: Node_Access
) return Boolean
827 return Key
(Right
.Element
) < Left
;
828 end Is_Greater_Key_Node
;
830 ----------------------
831 -- Is_Less_Key_Node --
832 ----------------------
834 function Is_Less_Key_Node
836 Right
: Node_Access
) return Boolean
839 return Left
< Key
(Right
.Element
);
840 end Is_Less_Key_Node
;
846 function Key
(Position
: Cursor
) return Key_Type
is
848 if Position
.Node
= null then
849 raise Constraint_Error
with
850 "Position cursor equals No_Element";
853 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
854 "bad cursor in Key");
856 return Key
(Position
.Node
.Element
);
864 (Stream
: not null access Root_Stream_Type
'Class;
865 Item
: out Reference_Type
)
868 raise Program_Error
with "attempt to stream reference";
871 ------------------------------
872 -- Reference_Preserving_Key --
873 ------------------------------
875 function Reference_Preserving_Key
876 (Container
: aliased in out Set
;
877 Position
: Cursor
) return Reference_Type
880 if Position
.Container
= null then
881 raise Constraint_Error
with "Position cursor has no element";
884 if Position
.Container
/= Container
'Unrestricted_Access then
885 raise Program_Error
with
886 "Position cursor designates wrong container";
890 (Vet
(Container
.Tree
, Position
.Node
),
891 "bad cursor in function Reference_Preserving_Key");
893 -- Some form of finalization will be required in order to actually
894 -- check that the key-part of the element designated by Position has
897 return (Element
=> Position
.Node
.Element
'Access);
898 end Reference_Preserving_Key
;
900 function Reference_Preserving_Key
901 (Container
: aliased in out Set
;
902 Key
: Key_Type
) return Reference_Type
904 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
908 raise Constraint_Error
with "key not in set";
911 -- Some form of finalization will be required in order to actually
912 -- check that the key-part of the element designated by Position has
915 return (Element
=> Node
.Element
'Access);
916 end Reference_Preserving_Key
;
923 (Container
: in out Set
;
925 New_Item
: Element_Type
)
927 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
931 raise Constraint_Error
with
932 "attempt to replace key not in set";
935 Replace_Element
(Container
.Tree
, Node
, New_Item
);
938 -----------------------------------
939 -- Update_Element_Preserving_Key --
940 -----------------------------------
942 procedure Update_Element_Preserving_Key
943 (Container
: in out Set
;
945 Process
: not null access procedure (Element
: in out Element_Type
))
947 Tree
: Tree_Type
renames Container
.Tree
;
950 if Position
.Node
= null then
951 raise Constraint_Error
with
952 "Position cursor equals No_Element";
955 if Position
.Container
/= Container
'Unrestricted_Access then
956 raise Program_Error
with
957 "Position cursor designates wrong set";
960 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
961 "bad cursor in Update_Element_Preserving_Key");
964 E
: Element_Type
renames Position
.Node
.Element
;
965 K
: constant Key_Type
:= Key
(E
);
967 B
: Natural renames Tree
.Busy
;
968 L
: Natural renames Tree
.Lock
;
978 Eq
:= Equivalent_Keys
(K
, Key
(E
));
995 X
: Node_Access
:= Position
.Node
;
997 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
1001 raise Program_Error
with "key was modified";
1002 end Update_Element_Preserving_Key
;
1009 (Stream
: not null access Root_Stream_Type
'Class;
1010 Item
: Reference_Type
)
1013 raise Program_Error
with "attempt to stream reference";
1022 function Has_Element
(Position
: Cursor
) return Boolean is
1024 return Position
/= No_Element
;
1031 procedure Include
(Container
: in out Set
; New_Item
: Element_Type
) is
1036 Insert
(Container
, New_Item
, Position
, Inserted
);
1038 if not Inserted
then
1039 if Container
.Tree
.Lock
> 0 then
1040 raise Program_Error
with
1041 "attempt to tamper with elements (set is locked)";
1044 Position
.Node
.Element
:= New_Item
;
1053 (Container
: in out Set
;
1054 New_Item
: Element_Type
;
1055 Position
: out Cursor
;
1056 Inserted
: out Boolean)
1065 Position
.Container
:= Container
'Unrestricted_Access;
1069 (Container
: in out Set
;
1070 New_Item
: Element_Type
)
1073 pragma Unreferenced
(Position
);
1078 Insert
(Container
, New_Item
, Position
, Inserted
);
1080 if not Inserted
then
1081 raise Constraint_Error
with
1082 "attempt to insert element already in set";
1086 ----------------------
1087 -- Insert_Sans_Hint --
1088 ----------------------
1090 procedure Insert_Sans_Hint
1091 (Tree
: in out Tree_Type
;
1092 New_Item
: Element_Type
;
1093 Node
: out Node_Access
;
1094 Inserted
: out Boolean)
1096 function New_Node
return Node_Access
;
1097 pragma Inline
(New_Node
);
1099 procedure Insert_Post
is
1100 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1102 procedure Conditional_Insert_Sans_Hint
is
1103 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
1109 function New_Node
return Node_Access
is
1111 return new Node_Type
'(Parent => null,
1114 Color => Red_Black_Trees.Red,
1115 Element => New_Item);
1118 -- Start of processing for Insert_Sans_Hint
1121 Conditional_Insert_Sans_Hint
1126 end Insert_Sans_Hint;
1128 ----------------------
1129 -- Insert_With_Hint --
1130 ----------------------
1132 procedure Insert_With_Hint
1133 (Dst_Tree : in out Tree_Type;
1134 Dst_Hint : Node_Access;
1135 Src_Node : Node_Access;
1136 Dst_Node : out Node_Access)
1139 pragma Unreferenced (Success);
1141 function New_Node return Node_Access;
1142 pragma Inline (New_Node);
1144 procedure Insert_Post is
1145 new Element_Keys.Generic_Insert_Post (New_Node);
1147 procedure Insert_Sans_Hint is
1148 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1150 procedure Local_Insert_With_Hint is
1151 new Element_Keys.Generic_Conditional_Insert_With_Hint
1159 function New_Node return Node_Access is
1160 Node : constant Node_Access :=
1161 new Node_Type'(Parent
=> null,
1165 Element
=> Src_Node
.Element
);
1170 -- Start of processing for Insert_With_Hint
1173 Local_Insert_With_Hint
1179 end Insert_With_Hint
;
1185 procedure Intersection
(Target
: in out Set
; Source
: Set
) is
1187 Set_Ops
.Intersection
(Target
.Tree
, Source
.Tree
);
1190 function Intersection
(Left
, Right
: Set
) return Set
is
1191 Tree
: constant Tree_Type
:=
1192 Set_Ops
.Intersection
(Left
.Tree
, Right
.Tree
);
1194 return Set
'(Controlled with Tree);
1201 function Is_Empty (Container : Set) return Boolean is
1203 return Container.Tree.Length = 0;
1206 ------------------------
1207 -- Is_Equal_Node_Node --
1208 ------------------------
1210 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1212 return L.Element = R.Element;
1213 end Is_Equal_Node_Node;
1215 -----------------------------
1216 -- Is_Greater_Element_Node --
1217 -----------------------------
1219 function Is_Greater_Element_Node
1220 (Left : Element_Type;
1221 Right : Node_Access) return Boolean
1224 -- Compute e > node same as node < e
1226 return Right.Element < Left;
1227 end Is_Greater_Element_Node;
1229 --------------------------
1230 -- Is_Less_Element_Node --
1231 --------------------------
1233 function Is_Less_Element_Node
1234 (Left : Element_Type;
1235 Right : Node_Access) return Boolean
1238 return Left < Right.Element;
1239 end Is_Less_Element_Node;
1241 -----------------------
1242 -- Is_Less_Node_Node --
1243 -----------------------
1245 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1247 return L.Element < R.Element;
1248 end Is_Less_Node_Node;
1254 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1256 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1265 Process : not null access procedure (Position : Cursor))
1267 procedure Process_Node (Node : Node_Access);
1268 pragma Inline (Process_Node);
1270 procedure Local_Iterate is
1271 new Tree_Operations.Generic_Iteration (Process_Node);
1277 procedure Process_Node (Node : Node_Access) is
1279 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1282 T
: Tree_Type
renames Container
'Unrestricted_Access.all.Tree
;
1283 B
: Natural renames T
.Busy
;
1285 -- Start of processing for Iterate
1301 function Iterate
(Container
: Set
)
1302 return Set_Iterator_Interfaces
.Reversible_Iterator
'Class
1304 B
: Natural renames Container
'Unrestricted_Access.all.Tree
.Busy
;
1307 -- The value of the Node component influences the behavior of the First
1308 -- and Last selector functions of the iterator object. When the Node
1309 -- component is null (as is the case here), this means the iterator
1310 -- object was constructed without a start expression. This is a complete
1311 -- iterator, meaning that the iteration starts from the (logical)
1312 -- beginning of the sequence of items.
1314 -- Note: For a forward iterator, Container.First is the beginning, and
1315 -- for a reverse iterator, Container.Last is the beginning.
1319 return It
: constant Iterator
:=
1320 Iterator
'(Limited_Controlled with
1321 Container => Container'Unrestricted_Access,
1325 function Iterate (Container : Set; Start : Cursor)
1326 return Set_Iterator_Interfaces.Reversible_Iterator'Class
1328 B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1331 -- It was formerly the case that when Start = No_Element, the partial
1332 -- iterator was defined to behave the same as for a complete iterator,
1333 -- and iterate over the entire sequence of items. However, those
1334 -- semantics were unintuitive and arguably error-prone (it is too easy
1335 -- to accidentally create an endless loop), and so they were changed,
1336 -- per the ARG meeting in Denver on 2011/11. However, there was no
1337 -- consensus about what positive meaning this corner case should have,
1338 -- and so it was decided to simply raise an exception. This does imply,
1339 -- however, that it is not possible to use a partial iterator to specify
1340 -- an empty sequence of items.
1342 if Start = No_Element then
1343 raise Constraint_Error with
1344 "Start position for iterator equals No_Element";
1347 if Start.Container /= Container'Unrestricted_Access then
1348 raise Program_Error with
1349 "Start cursor of Iterate designates wrong set";
1352 pragma Assert (Vet (Container.Tree, Start.Node),
1353 "Start cursor of Iterate is bad");
1355 -- The value of the Node component influences the behavior of the First
1356 -- and Last selector functions of the iterator object. When the Node
1357 -- component is non-null (as is the case here), it means that this is a
1358 -- partial iteration, over a subset of the complete sequence of
1359 -- items. The iterator object was constructed with a start expression,
1360 -- indicating the position from which the iteration begins. Note that
1361 -- the start position has the same value irrespective of whether this is
1362 -- a forward or reverse iteration.
1366 return It : constant Iterator :=
1367 Iterator'(Limited_Controlled
with
1368 Container
=> Container
'Unrestricted_Access,
1369 Node
=> Start
.Node
);
1376 function Last
(Container
: Set
) return Cursor
is
1379 (if Container
.Tree
.Last
= null then No_Element
1380 else Cursor
'(Container'Unrestricted_Access, Container.Tree.Last));
1383 function Last (Object : Iterator) return Cursor is
1385 -- The value of the iterator object's Node component influences the
1386 -- behavior of the Last (and First) selector function.
1388 -- When the Node component is null, this means the iterator object was
1389 -- constructed without a start expression, in which case the (reverse)
1390 -- iteration starts from the (logical) beginning of the entire sequence
1391 -- (corresponding to Container.Last, for a reverse iterator).
1393 -- Otherwise, this is iteration over a partial sequence of items. When
1394 -- the Node component is non-null, the iterator object was constructed
1395 -- with a start expression, that specifies the position from which the
1396 -- (reverse) partial iteration begins.
1398 if Object.Node = null then
1399 return Object.Container.Last;
1401 return Cursor'(Object
.Container
, Object
.Node
);
1409 function Last_Element
(Container
: Set
) return Element_Type
is
1411 if Container
.Tree
.Last
= null then
1412 raise Constraint_Error
with "set is empty";
1414 return Container
.Tree
.Last
.Element
;
1422 function Left
(Node
: Node_Access
) return Node_Access
is
1431 function Length
(Container
: Set
) return Count_Type
is
1433 return Container
.Tree
.Length
;
1440 procedure Move
is new Tree_Operations
.Generic_Move
(Clear
);
1442 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1444 Move
(Target
=> Target
.Tree
, Source
=> Source
.Tree
);
1451 function Next
(Position
: Cursor
) return Cursor
is
1453 if Position
= No_Element
then
1457 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1458 "bad cursor in Next");
1461 Node
: constant Node_Access
:=
1462 Tree_Operations
.Next
(Position
.Node
);
1464 return (if Node
= null then No_Element
1465 else Cursor
'(Position.Container, Node));
1469 procedure Next (Position : in out Cursor) is
1471 Position := Next (Position);
1474 function Next (Object : Iterator; Position : Cursor) return Cursor is
1476 if Position.Container = null then
1480 if Position.Container /= Object.Container then
1481 raise Program_Error with
1482 "Position cursor of Next designates wrong set";
1485 return Next (Position);
1492 function Overlap (Left, Right : Set) return Boolean is
1494 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1501 function Parent (Node : Node_Access) return Node_Access is
1510 function Previous (Position : Cursor) return Cursor is
1512 if Position = No_Element then
1516 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1517 "bad cursor in Previous");
1520 Node : constant Node_Access :=
1521 Tree_Operations.Previous (Position.Node);
1523 return (if Node = null then No_Element
1524 else Cursor'(Position
.Container
, Node
));
1528 procedure Previous
(Position
: in out Cursor
) is
1530 Position
:= Previous
(Position
);
1533 function Previous
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
1535 if Position
.Container
= null then
1539 if Position
.Container
/= Object
.Container
then
1540 raise Program_Error
with
1541 "Position cursor of Previous designates wrong set";
1544 return Previous
(Position
);
1551 procedure Query_Element
1553 Process
: not null access procedure (Element
: Element_Type
))
1556 if Position
.Node
= null then
1557 raise Constraint_Error
with "Position cursor equals No_Element";
1560 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1561 "bad cursor in Query_Element");
1564 T
: Tree_Type
renames Position
.Container
.Tree
;
1566 B
: Natural renames T
.Busy
;
1567 L
: Natural renames T
.Lock
;
1574 Process
(Position
.Node
.Element
);
1592 (Stream
: not null access Root_Stream_Type
'Class;
1593 Container
: out Set
)
1596 (Stream
: not null access Root_Stream_Type
'Class) return Node_Access
;
1597 pragma Inline
(Read_Node
);
1600 new Tree_Operations
.Generic_Read
(Clear
, Read_Node
);
1607 (Stream
: not null access Root_Stream_Type
'Class) return Node_Access
1609 Node
: Node_Access
:= new Node_Type
;
1611 Element_Type
'Read (Stream
, Node
.Element
);
1619 -- Start of processing for Read
1622 Read
(Stream
, Container
.Tree
);
1626 (Stream
: not null access Root_Stream_Type
'Class;
1630 raise Program_Error
with "attempt to stream set cursor";
1634 (Stream
: not null access Root_Stream_Type
'Class;
1635 Item
: out Constant_Reference_Type
)
1638 raise Program_Error
with "attempt to stream reference";
1645 procedure Replace
(Container
: in out Set
; New_Item
: Element_Type
) is
1646 Node
: constant Node_Access
:=
1647 Element_Keys
.Find
(Container
.Tree
, New_Item
);
1651 raise Constraint_Error
with
1652 "attempt to replace element not in set";
1655 if Container
.Tree
.Lock
> 0 then
1656 raise Program_Error
with
1657 "attempt to tamper with elements (set is locked)";
1660 Node
.Element
:= New_Item
;
1663 ---------------------
1664 -- Replace_Element --
1665 ---------------------
1667 procedure Replace_Element
1668 (Tree
: in out Tree_Type
;
1670 Item
: Element_Type
)
1672 pragma Assert
(Node
/= null);
1674 function New_Node
return Node_Access
;
1675 pragma Inline
(New_Node
);
1677 procedure Local_Insert_Post
is
1678 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1680 procedure Local_Insert_Sans_Hint
is
1681 new Element_Keys
.Generic_Conditional_Insert
(Local_Insert_Post
);
1683 procedure Local_Insert_With_Hint
is
1684 new Element_Keys
.Generic_Conditional_Insert_With_Hint
1686 Local_Insert_Sans_Hint
);
1692 function New_Node
return Node_Access
is
1694 Node
.Element
:= Item
;
1696 Node
.Parent
:= null;
1703 Result
: Node_Access
;
1707 -- Per AI05-0022, the container implementation is required to detect
1708 -- element tampering by a generic actual subprogram.
1710 B
: Natural renames Tree
.Busy
;
1711 L
: Natural renames Tree
.Lock
;
1713 -- Start of processing for Replace_Element
1716 -- Replace_Element assigns value Item to the element designated by Node,
1717 -- per certain semantic constraints.
1719 -- If Item is equivalent to the element, then element is replaced and
1720 -- there's nothing else to do. This is the easy case.
1722 -- If Item is not equivalent, then the node will (possibly) have to move
1723 -- to some other place in the tree. This is slighly more complicated,
1724 -- because we must ensure that Item is not equivalent to some other
1725 -- element in the tree (in which case, the replacement is not allowed).
1727 -- Determine whether Item is equivalent to element on the specified
1734 Compare
:= (if Item
< Node
.Element
then False
1735 elsif Node
.Element
< Item
then False
1749 -- Item is equivalent to the node's element, so we will not have to
1752 if Tree
.Lock
> 0 then
1753 raise Program_Error
with
1754 "attempt to tamper with elements (set is locked)";
1757 Node
.Element
:= Item
;
1761 -- The replacement Item is not equivalent to the element on the
1762 -- specified node, which means that it will need to be re-inserted in a
1763 -- different position in the tree. We must now determine whether Item is
1764 -- equivalent to some other element in the tree (which would prohibit
1765 -- the assignment and hence the move).
1767 -- Ceiling returns the smallest element equivalent or greater than the
1768 -- specified Item; if there is no such element, then it returns null.
1770 Hint
:= Element_Keys
.Ceiling
(Tree
, Item
);
1772 if Hint
/= null then
1777 Compare
:= Item
< Hint
.Element
;
1789 -- Item >= Hint.Element
1793 -- Ceiling returns an element that is equivalent or greater
1794 -- than Item. If Item is "not less than" the element, then
1795 -- by elimination we know that Item is equivalent to the element.
1797 -- But this means that it is not possible to assign the value of
1798 -- Item to the specified element (on Node), because a different
1799 -- element (on Hint) equivalent to Item already exsits. (Were we
1800 -- to change Node's element value, we would have to move Node, but
1801 -- we would be unable to move the Node, because its new position
1802 -- in the tree is already occupied by an equivalent element.)
1804 raise Program_Error
with "attempt to replace existing element";
1807 -- Item is not equivalent to any other element in the tree, so it is
1808 -- safe to assign the value of Item to Node.Element. This means that
1809 -- the node will have to move to a different position in the tree
1810 -- (because its element will have a different value).
1812 -- The nearest (greater) neighbor of Item is Hint. This will be the
1813 -- insertion position of Node (because its element will have Item as
1816 -- If Node equals Hint, the relative position of Node does not
1817 -- change. This allows us to perform an optimization: we need not
1818 -- remove Node from the tree and then reinsert it with its new value,
1819 -- because it would only be placed in the exact same position.
1822 if Tree
.Lock
> 0 then
1823 raise Program_Error
with
1824 "attempt to tamper with elements (set is locked)";
1827 Node
.Element
:= Item
;
1832 -- If we get here, it is because Item was greater than all elements in
1833 -- the tree (Hint = null), or because Item was less than some element at
1834 -- a different place in the tree (Item < Hint.Element). In either case,
1835 -- we remove Node from the tree (without actually deallocating it), and
1836 -- then insert Item into the tree, onto the same Node (so no new node is
1837 -- actually allocated).
1839 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Node
); -- Checks busy-bit
1841 Local_Insert_With_Hint
-- use unconditional insert here instead???
1846 Inserted
=> Inserted
);
1848 pragma Assert
(Inserted
);
1849 pragma Assert
(Result
= Node
);
1850 end Replace_Element
;
1852 procedure Replace_Element
1853 (Container
: in out Set
;
1855 New_Item
: Element_Type
)
1858 if Position
.Node
= null then
1859 raise Constraint_Error
with
1860 "Position cursor equals No_Element";
1863 if Position
.Container
/= Container
'Unrestricted_Access then
1864 raise Program_Error
with
1865 "Position cursor designates wrong set";
1868 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
1869 "bad cursor in Replace_Element");
1871 Replace_Element
(Container
.Tree
, Position
.Node
, New_Item
);
1872 end Replace_Element
;
1874 ---------------------
1875 -- Reverse_Iterate --
1876 ---------------------
1878 procedure Reverse_Iterate
1880 Process
: not null access procedure (Position
: Cursor
))
1882 procedure Process_Node
(Node
: Node_Access
);
1883 pragma Inline
(Process_Node
);
1885 procedure Local_Reverse_Iterate
is
1886 new Tree_Operations
.Generic_Reverse_Iteration
(Process_Node
);
1892 procedure Process_Node
(Node
: Node_Access
) is
1894 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1897 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1898 B : Natural renames T.Busy;
1900 -- Start of processing for Reverse_Iterate
1906 Local_Reverse_Iterate (T);
1914 end Reverse_Iterate;
1920 function Right (Node : Node_Access) return Node_Access is
1929 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1931 Node.Color := Color;
1938 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1947 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1949 Node.Parent := Parent;
1956 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1958 Node.Right := Right;
1961 --------------------------
1962 -- Symmetric_Difference --
1963 --------------------------
1965 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1967 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1968 end Symmetric_Difference;
1970 function Symmetric_Difference (Left, Right : Set) return Set is
1971 Tree : constant Tree_Type :=
1972 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1974 return Set'(Controlled
with Tree
);
1975 end Symmetric_Difference
;
1981 function To_Set
(New_Item
: Element_Type
) return Set
is
1985 pragma Unreferenced
(Node
, Inserted
);
1987 Insert_Sans_Hint
(Tree
, New_Item
, Node
, Inserted
);
1988 return Set
'(Controlled with Tree);
1995 procedure Union (Target : in out Set; Source : Set) is
1997 Set_Ops.Union (Target.Tree, Source.Tree);
2000 function Union (Left, Right : Set) return Set is
2001 Tree : constant Tree_Type :=
2002 Set_Ops.Union (Left.Tree, Right.Tree);
2004 return Set'(Controlled
with Tree
);
2012 (Stream
: not null access Root_Stream_Type
'Class;
2015 procedure Write_Node
2016 (Stream
: not null access Root_Stream_Type
'Class;
2017 Node
: Node_Access
);
2018 pragma Inline
(Write_Node
);
2021 new Tree_Operations
.Generic_Write
(Write_Node
);
2027 procedure Write_Node
2028 (Stream
: not null access Root_Stream_Type
'Class;
2032 Element_Type
'Write (Stream
, Node
.Element
);
2035 -- Start of processing for Write
2038 Write
(Stream
, Container
.Tree
);
2042 (Stream
: not null access Root_Stream_Type
'Class;
2046 raise Program_Error
with "attempt to stream set cursor";
2050 (Stream
: not null access Root_Stream_Type
'Class;
2051 Item
: Constant_Reference_Type
)
2054 raise Program_Error
with "attempt to stream reference";
2057 end Ada
.Containers
.Ordered_Sets
;