1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . B O U N D E D _ 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
.Containers
.Red_Black_Trees
.Generic_Bounded_Operations
;
32 (Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Operations
);
34 with Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Keys
;
35 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Keys
);
37 with Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Set_Operations
;
39 (Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Set_Operations
);
41 with System
; use type System
.Address
;
43 package body Ada
.Containers
.Bounded_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_Type
) return Red_Black_Trees
.Color_Type
;
53 pragma Inline
(Color
);
55 function Left
(Node
: Node_Type
) return Count_Type
;
58 function Parent
(Node
: Node_Type
) return Count_Type
;
59 pragma Inline
(Parent
);
61 function Right
(Node
: Node_Type
) return Count_Type
;
62 pragma Inline
(Right
);
65 (Node
: in out Node_Type
;
66 Color
: Red_Black_Trees
.Color_Type
);
67 pragma Inline
(Set_Color
);
69 procedure Set_Left
(Node
: in out Node_Type
; Left
: Count_Type
);
70 pragma Inline
(Set_Left
);
72 procedure Set_Right
(Node
: in out Node_Type
; Right
: Count_Type
);
73 pragma Inline
(Set_Right
);
75 procedure Set_Parent
(Node
: in out Node_Type
; Parent
: Count_Type
);
76 pragma Inline
(Set_Parent
);
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 procedure Insert_Sans_Hint
83 (Container
: in out Set
;
84 New_Item
: Element_Type
;
85 Node
: out Count_Type
;
86 Inserted
: out Boolean);
88 procedure Insert_With_Hint
89 (Dst_Set
: in out Set
;
90 Dst_Hint
: Count_Type
;
92 Dst_Node
: out Count_Type
);
94 function Is_Greater_Element_Node
96 Right
: Node_Type
) return Boolean;
97 pragma Inline
(Is_Greater_Element_Node
);
99 function Is_Less_Element_Node
100 (Left
: Element_Type
;
101 Right
: Node_Type
) return Boolean;
102 pragma Inline
(Is_Less_Element_Node
);
104 function Is_Less_Node_Node
(L
, R
: Node_Type
) return Boolean;
105 pragma Inline
(Is_Less_Node_Node
);
107 procedure Replace_Element
108 (Container
: in out Set
;
110 Item
: Element_Type
);
112 --------------------------
113 -- Local Instantiations --
114 --------------------------
116 package Tree_Operations
is
117 new Red_Black_Trees
.Generic_Bounded_Operations
(Tree_Types
);
121 package Element_Keys
is
122 new Red_Black_Trees
.Generic_Bounded_Keys
123 (Tree_Operations
=> Tree_Operations
,
124 Key_Type
=> Element_Type
,
125 Is_Less_Key_Node
=> Is_Less_Element_Node
,
126 Is_Greater_Key_Node
=> Is_Greater_Element_Node
);
129 new Red_Black_Trees
.Generic_Bounded_Set_Operations
130 (Tree_Operations
=> Tree_Operations
,
133 Insert_With_Hint
=> Insert_With_Hint
,
134 Is_Less
=> Is_Less_Node_Node
);
140 function "<" (Left
, Right
: Cursor
) return Boolean is
142 if Left
.Node
= 0 then
143 raise Constraint_Error
with "Left cursor equals No_Element";
146 if Right
.Node
= 0 then
147 raise Constraint_Error
with "Right cursor equals No_Element";
150 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
151 "bad Left cursor in ""<""");
153 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
154 "bad Right cursor in ""<""");
157 LN
: Nodes_Type
renames Left
.Container
.Nodes
;
158 RN
: Nodes_Type
renames Right
.Container
.Nodes
;
160 return LN
(Left
.Node
).Element
< RN
(Right
.Node
).Element
;
164 function "<" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
166 if Left
.Node
= 0 then
167 raise Constraint_Error
with "Left cursor equals No_Element";
170 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
171 "bad Left cursor in ""<""");
173 return Left
.Container
.Nodes
(Left
.Node
).Element
< Right
;
176 function "<" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
178 if Right
.Node
= 0 then
179 raise Constraint_Error
with "Right cursor equals No_Element";
182 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
183 "bad Right cursor in ""<""");
185 return Left
< Right
.Container
.Nodes
(Right
.Node
).Element
;
192 function "=" (Left
, Right
: Set
) return Boolean is
193 function Is_Equal_Node_Node
(L
, R
: Node_Type
) return Boolean;
194 pragma Inline
(Is_Equal_Node_Node
);
197 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
199 ------------------------
200 -- Is_Equal_Node_Node --
201 ------------------------
203 function Is_Equal_Node_Node
(L
, R
: Node_Type
) return Boolean is
205 return L
.Element
= R
.Element
;
206 end Is_Equal_Node_Node
;
208 -- Start of processing for Is_Equal
211 return Is_Equal
(Left
, Right
);
218 function ">" (Left
, Right
: Cursor
) return Boolean is
220 if Left
.Node
= 0 then
221 raise Constraint_Error
with "Left cursor equals No_Element";
224 if Right
.Node
= 0 then
225 raise Constraint_Error
with "Right cursor equals No_Element";
228 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
229 "bad Left cursor in "">""");
231 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
232 "bad Right cursor in "">""");
234 -- L > R same as R < L
237 LN
: Nodes_Type
renames Left
.Container
.Nodes
;
238 RN
: Nodes_Type
renames Right
.Container
.Nodes
;
240 return RN
(Right
.Node
).Element
< LN
(Left
.Node
).Element
;
244 function ">" (Left
: Element_Type
; Right
: Cursor
) return Boolean is
246 if Right
.Node
= 0 then
247 raise Constraint_Error
with "Right cursor equals No_Element";
250 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
251 "bad Right cursor in "">""");
253 return Right
.Container
.Nodes
(Right
.Node
).Element
< Left
;
256 function ">" (Left
: Cursor
; Right
: Element_Type
) return Boolean is
258 if Left
.Node
= 0 then
259 raise Constraint_Error
with "Left cursor equals No_Element";
262 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
263 "bad Left cursor in "">""");
265 return Right
< Left
.Container
.Nodes
(Left
.Node
).Element
;
272 procedure Assign
(Target
: in out Set
; Source
: Set
) is
273 procedure Append_Element
(Source_Node
: Count_Type
);
275 procedure Append_Elements
is
276 new Tree_Operations
.Generic_Iteration
(Append_Element
);
282 procedure Append_Element
(Source_Node
: Count_Type
) is
283 SN
: Node_Type
renames Source
.Nodes
(Source_Node
);
285 procedure Set_Element
(Node
: in out Node_Type
);
286 pragma Inline
(Set_Element
);
288 function New_Node
return Count_Type
;
289 pragma Inline
(New_Node
);
291 procedure Insert_Post
is
292 new Element_Keys
.Generic_Insert_Post
(New_Node
);
294 procedure Unconditional_Insert_Sans_Hint
is
295 new Element_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
297 procedure Unconditional_Insert_Avec_Hint
is
298 new Element_Keys
.Generic_Unconditional_Insert_With_Hint
300 Unconditional_Insert_Sans_Hint
);
302 procedure Allocate
is
303 new Tree_Operations
.Generic_Allocate
(Set_Element
);
309 function New_Node
return Count_Type
is
312 Allocate
(Target
, Result
);
320 procedure Set_Element
(Node
: in out Node_Type
) is
322 Node
.Element
:= SN
.Element
;
325 Target_Node
: Count_Type
;
327 -- Start of processing for Append_Element
330 Unconditional_Insert_Avec_Hint
334 Node
=> Target_Node
);
337 -- Start of processing for Assign
340 if Target
'Address = Source
'Address then
344 if Target
.Capacity
< Source
.Length
then
346 with "Target capacity is less than Source length";
350 Append_Elements
(Source
);
357 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
is
358 Node
: constant Count_Type
:=
359 Element_Keys
.Ceiling
(Container
, Item
);
361 return (if Node
= 0 then No_Element
362 else Cursor
'(Container'Unrestricted_Access, Node));
369 procedure Clear (Container : in out Set) is
371 Tree_Operations.Clear_Tree (Container);
378 function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is
383 ------------------------
384 -- Constant_Reference --
385 ------------------------
387 function Constant_Reference
388 (Container : aliased Set;
389 Position : Cursor) return Constant_Reference_Type
392 if Position.Container = null then
393 raise Constraint_Error with "Position cursor has no element";
396 if Position.Container /= Container'Unrestricted_Access then
397 raise Program_Error with
398 "Position cursor designates wrong container";
402 (Vet (Container, Position.Node),
403 "bad cursor in Constant_Reference");
406 N : Node_Type renames Container.Nodes (Position.Node);
408 return (Element => N.Element'Access);
410 end Constant_Reference;
418 Item : Element_Type) return Boolean
421 return Find (Container, Item) /= No_Element;
428 function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
434 elsif Capacity >= Source.Length then
437 raise Capacity_Error with "Capacity value too small";
440 return Target : Set (Capacity => C) do
441 Assign (Target => Target, Source => Source);
449 procedure Delete (Container : in out Set; Position : in out Cursor) is
451 if Position.Node = 0 then
452 raise Constraint_Error with "Position cursor equals No_Element";
455 if Position.Container /= Container'Unrestricted_Access then
456 raise Program_Error with "Position cursor designates wrong set";
459 pragma Assert (Vet (Container, Position.Node),
460 "bad cursor in Delete");
462 Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
463 Tree_Operations.Free (Container, Position.Node);
465 Position := No_Element;
468 procedure Delete (Container : in out Set; Item : Element_Type) is
469 X : constant Count_Type := Element_Keys.Find (Container, Item);
473 raise Constraint_Error with "attempt to delete element not in set";
476 Tree_Operations.Delete_Node_Sans_Free (Container, X);
477 Tree_Operations.Free (Container, X);
484 procedure Delete_First (Container : in out Set) is
485 X : constant Count_Type := Container.First;
488 Tree_Operations.Delete_Node_Sans_Free (Container, X);
489 Tree_Operations.Free (Container, X);
497 procedure Delete_Last (Container : in out Set) is
498 X : constant Count_Type := Container.Last;
501 Tree_Operations.Delete_Node_Sans_Free (Container, X);
502 Tree_Operations.Free (Container, X);
510 procedure Difference (Target : in out Set; Source : Set)
511 renames Set_Ops.Set_Difference;
513 function Difference (Left, Right : Set) return Set
514 renames Set_Ops.Set_Difference;
520 function Element (Position : Cursor) return Element_Type is
522 if Position.Node = 0 then
523 raise Constraint_Error with "Position cursor equals No_Element";
526 pragma Assert (Vet (Position.Container.all, Position.Node),
527 "bad cursor in Element");
529 return Position.Container.Nodes (Position.Node).Element;
532 -------------------------
533 -- Equivalent_Elements --
534 -------------------------
536 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
538 return (if Left < Right or else Right < Left then False else True);
539 end Equivalent_Elements;
541 ---------------------
542 -- Equivalent_Sets --
543 ---------------------
545 function Equivalent_Sets (Left, Right : Set) return Boolean is
546 function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean;
547 pragma Inline (Is_Equivalent_Node_Node);
549 function Is_Equivalent is
550 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
552 -----------------------------
553 -- Is_Equivalent_Node_Node --
554 -----------------------------
556 function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is
558 return (if L.Element < R.Element then False
559 elsif R.Element < L.Element then False
561 end Is_Equivalent_Node_Node;
563 -- Start of processing for Equivalent_Sets
566 return Is_Equivalent (Left, Right);
573 procedure Exclude (Container : in out Set; Item : Element_Type) is
574 X : constant Count_Type := Element_Keys.Find (Container, Item);
577 Tree_Operations.Delete_Node_Sans_Free (Container, X);
578 Tree_Operations.Free (Container, X);
586 procedure Finalize (Object : in out Iterator) is
588 if Object.Container /= null then
590 B : Natural renames Object.Container.all.Busy;
601 function Find (Container : Set; Item : Element_Type) return Cursor is
602 Node : constant Count_Type := Element_Keys.Find (Container, Item);
604 return (if Node = 0 then No_Element
605 else Cursor'(Container
'Unrestricted_Access, Node
));
612 function First
(Container
: Set
) return Cursor
is
614 return (if Container
.First
= 0 then No_Element
615 else Cursor
'(Container'Unrestricted_Access, Container.First));
618 function First (Object : Iterator) return Cursor is
620 -- The value of the iterator object's Node component influences the
621 -- behavior of the First (and Last) selector function.
623 -- When the Node component is 0, this means the iterator object was
624 -- constructed without a start expression, in which case the (forward)
625 -- iteration starts from the (logical) beginning of the entire sequence
626 -- of items (corresponding to Container.First, for a forward iterator).
628 -- Otherwise, this is iteration over a partial sequence of items. When
629 -- the Node component is positive, the iterator object was constructed
630 -- with a start expression, that specifies the position from which the
631 -- (forward) partial iteration begins.
633 if Object.Node = 0 then
634 return Bounded_Ordered_Sets.First (Object.Container.all);
636 return Cursor'(Object
.Container
, Object
.Node
);
644 function First_Element
(Container
: Set
) return Element_Type
is
646 if Container
.First
= 0 then
647 raise Constraint_Error
with "set is empty";
650 return Container
.Nodes
(Container
.First
).Element
;
657 function Floor
(Container
: Set
; Item
: Element_Type
) return Cursor
is
658 Node
: constant Count_Type
:= Element_Keys
.Floor
(Container
, Item
);
660 return (if Node
= 0 then No_Element
661 else Cursor
'(Container'Unrestricted_Access, Node));
668 package body Generic_Keys is
670 -----------------------
671 -- Local Subprograms --
672 -----------------------
674 function Is_Greater_Key_Node
676 Right : Node_Type) return Boolean;
677 pragma Inline (Is_Greater_Key_Node);
679 function Is_Less_Key_Node
681 Right : Node_Type) return Boolean;
682 pragma Inline (Is_Less_Key_Node);
684 --------------------------
685 -- Local Instantiations --
686 --------------------------
689 new Red_Black_Trees.Generic_Bounded_Keys
690 (Tree_Operations => Tree_Operations,
691 Key_Type => Key_Type,
692 Is_Less_Key_Node => Is_Less_Key_Node,
693 Is_Greater_Key_Node => Is_Greater_Key_Node);
699 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
700 Node : constant Count_Type :=
701 Key_Keys.Ceiling (Container, Key);
703 return (if Node = 0 then No_Element
704 else Cursor'(Container
'Unrestricted_Access, Node
));
707 ------------------------
708 -- Constant_Reference --
709 ------------------------
711 function Constant_Reference
712 (Container
: aliased Set
;
713 Key
: Key_Type
) return Constant_Reference_Type
715 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
719 raise Constraint_Error
with "key not in set";
723 N
: Node_Type
renames Container
.Nodes
(Node
);
725 return (Element
=> N
.Element
'Access);
727 end Constant_Reference
;
733 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean is
735 return Find
(Container
, Key
) /= No_Element
;
742 procedure Delete
(Container
: in out Set
; Key
: Key_Type
) is
743 X
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
747 raise Constraint_Error
with "attempt to delete key not in set";
750 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
751 Tree_Operations
.Free
(Container
, X
);
758 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
is
759 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
763 raise Constraint_Error
with "key not in set";
766 return Container
.Nodes
(Node
).Element
;
769 ---------------------
770 -- Equivalent_Keys --
771 ---------------------
773 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
775 return (if Left
< Right
or else Right
< Left
then False else True);
782 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
) is
783 X
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
786 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
787 Tree_Operations
.Free
(Container
, X
);
795 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
is
796 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
798 return (if Node
= 0 then No_Element
799 else Cursor
'(Container'Unrestricted_Access, Node));
806 function Floor (Container : Set; Key : Key_Type) return Cursor is
807 Node : constant Count_Type := Key_Keys.Floor (Container, Key);
809 return (if Node = 0 then No_Element
810 else Cursor'(Container
'Unrestricted_Access, Node
));
813 -------------------------
814 -- Is_Greater_Key_Node --
815 -------------------------
817 function Is_Greater_Key_Node
819 Right
: Node_Type
) return Boolean
822 return Key
(Right
.Element
) < Left
;
823 end Is_Greater_Key_Node
;
825 ----------------------
826 -- Is_Less_Key_Node --
827 ----------------------
829 function Is_Less_Key_Node
831 Right
: Node_Type
) return Boolean
834 return Left
< Key
(Right
.Element
);
835 end Is_Less_Key_Node
;
841 function Key
(Position
: Cursor
) return Key_Type
is
843 if Position
.Node
= 0 then
844 raise Constraint_Error
with
845 "Position cursor equals No_Element";
848 pragma Assert
(Vet
(Position
.Container
.all, Position
.Node
),
849 "bad cursor in Key");
851 return Key
(Position
.Container
.Nodes
(Position
.Node
).Element
);
859 (Stream
: not null access Root_Stream_Type
'Class;
860 Item
: out Reference_Type
)
863 raise Program_Error
with "attempt to stream reference";
866 ------------------------------
867 -- Reference_Preserving_Key --
868 ------------------------------
870 function Reference_Preserving_Key
871 (Container
: aliased in out Set
;
872 Position
: Cursor
) return Reference_Type
875 if Position
.Container
= null then
876 raise Constraint_Error
with "Position cursor has no element";
879 if Position
.Container
/= Container
'Unrestricted_Access then
880 raise Program_Error
with
881 "Position cursor designates wrong container";
885 (Vet
(Container
, Position
.Node
),
886 "bad cursor in function Reference_Preserving_Key");
888 -- Some form of finalization will be required in order to actually
889 -- check that the key-part of the element designated by Position has
893 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
895 return (Element
=> N
.Element
'Access);
897 end Reference_Preserving_Key
;
899 function Reference_Preserving_Key
900 (Container
: aliased in out Set
;
901 Key
: Key_Type
) return Reference_Type
903 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
907 raise Constraint_Error
with "key not in set";
911 N
: Node_Type
renames Container
.Nodes
(Node
);
913 return (Element
=> N
.Element
'Access);
915 end Reference_Preserving_Key
;
922 (Container
: in out Set
;
924 New_Item
: Element_Type
)
926 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
930 raise Constraint_Error
with
931 "attempt to replace key not in set";
934 Replace_Element
(Container
, Node
, New_Item
);
937 -----------------------------------
938 -- Update_Element_Preserving_Key --
939 -----------------------------------
941 procedure Update_Element_Preserving_Key
942 (Container
: in out Set
;
944 Process
: not null access procedure (Element
: in out Element_Type
))
947 if Position
.Node
= 0 then
948 raise Constraint_Error
with
949 "Position cursor equals No_Element";
952 if Position
.Container
/= Container
'Unrestricted_Access then
953 raise Program_Error
with
954 "Position cursor designates wrong set";
957 pragma Assert
(Vet
(Container
, Position
.Node
),
958 "bad cursor in Update_Element_Preserving_Key");
960 -- Per AI05-0022, the container implementation is required to detect
961 -- element tampering by a generic actual subprogram.
964 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
965 E
: Element_Type
renames N
.Element
;
966 K
: constant Key_Type
:= Key
(E
);
968 B
: Natural renames Container
.Busy
;
969 L
: Natural renames Container
.Lock
;
979 Eq
:= Equivalent_Keys
(K
, Key
(E
));
995 Tree_Operations
.Delete_Node_Sans_Free
(Container
, Position
.Node
);
996 Tree_Operations
.Free
(Container
, Position
.Node
);
998 raise Program_Error
with "key was modified";
999 end Update_Element_Preserving_Key
;
1006 (Stream
: not null access Root_Stream_Type
'Class;
1007 Item
: Reference_Type
)
1010 raise Program_Error
with "attempt to stream reference";
1018 function Has_Element
(Position
: Cursor
) return Boolean is
1020 return Position
/= No_Element
;
1027 procedure Include
(Container
: in out Set
; New_Item
: Element_Type
) is
1032 Insert
(Container
, New_Item
, Position
, Inserted
);
1034 if not Inserted
then
1035 if Container
.Lock
> 0 then
1036 raise Program_Error
with
1037 "attempt to tamper with elements (set is locked)";
1040 Container
.Nodes
(Position
.Node
).Element
:= New_Item
;
1049 (Container
: in out Set
;
1050 New_Item
: Element_Type
;
1051 Position
: out Cursor
;
1052 Inserted
: out Boolean)
1061 Position
.Container
:= Container
'Unrestricted_Access;
1065 (Container
: in out Set
;
1066 New_Item
: Element_Type
)
1069 pragma Unreferenced
(Position
);
1074 Insert
(Container
, New_Item
, Position
, Inserted
);
1076 if not Inserted
then
1077 raise Constraint_Error
with
1078 "attempt to insert element already in set";
1082 ----------------------
1083 -- Insert_Sans_Hint --
1084 ----------------------
1086 procedure Insert_Sans_Hint
1087 (Container
: in out Set
;
1088 New_Item
: Element_Type
;
1089 Node
: out Count_Type
;
1090 Inserted
: out Boolean)
1092 procedure Set_Element
(Node
: in out Node_Type
);
1093 pragma Inline
(Set_Element
);
1095 function New_Node
return Count_Type
;
1096 pragma Inline
(New_Node
);
1098 procedure Insert_Post
is
1099 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1101 procedure Conditional_Insert_Sans_Hint
is
1102 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
1104 procedure Allocate
is
1105 new Tree_Operations
.Generic_Allocate
(Set_Element
);
1111 function New_Node
return Count_Type
is
1112 Result
: Count_Type
;
1114 Allocate
(Container
, Result
);
1122 procedure Set_Element
(Node
: in out Node_Type
) is
1124 Node
.Element
:= New_Item
;
1127 -- Start of processing for Insert_Sans_Hint
1130 Conditional_Insert_Sans_Hint
1135 end Insert_Sans_Hint
;
1137 ----------------------
1138 -- Insert_With_Hint --
1139 ----------------------
1141 procedure Insert_With_Hint
1142 (Dst_Set
: in out Set
;
1143 Dst_Hint
: Count_Type
;
1144 Src_Node
: Node_Type
;
1145 Dst_Node
: out Count_Type
)
1148 pragma Unreferenced
(Success
);
1150 procedure Set_Element
(Node
: in out Node_Type
);
1151 pragma Inline
(Set_Element
);
1153 function New_Node
return Count_Type
;
1154 pragma Inline
(New_Node
);
1156 procedure Insert_Post
is
1157 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1159 procedure Insert_Sans_Hint
is
1160 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
1162 procedure Local_Insert_With_Hint
is
1163 new Element_Keys
.Generic_Conditional_Insert_With_Hint
1167 procedure Allocate
is
1168 new Tree_Operations
.Generic_Allocate
(Set_Element
);
1174 function New_Node
return Count_Type
is
1175 Result
: Count_Type
;
1177 Allocate
(Dst_Set
, Result
);
1185 procedure Set_Element
(Node
: in out Node_Type
) is
1187 Node
.Element
:= Src_Node
.Element
;
1190 -- Start of processing for Insert_With_Hint
1193 Local_Insert_With_Hint
1199 end Insert_With_Hint
;
1205 procedure Intersection
(Target
: in out Set
; Source
: Set
)
1206 renames Set_Ops
.Set_Intersection
;
1208 function Intersection
(Left
, Right
: Set
) return Set
1209 renames Set_Ops
.Set_Intersection
;
1215 function Is_Empty
(Container
: Set
) return Boolean is
1217 return Container
.Length
= 0;
1220 -----------------------------
1221 -- Is_Greater_Element_Node --
1222 -----------------------------
1224 function Is_Greater_Element_Node
1225 (Left
: Element_Type
;
1226 Right
: Node_Type
) return Boolean
1229 -- Compute e > node same as node < e
1231 return Right
.Element
< Left
;
1232 end Is_Greater_Element_Node
;
1234 --------------------------
1235 -- Is_Less_Element_Node --
1236 --------------------------
1238 function Is_Less_Element_Node
1239 (Left
: Element_Type
;
1240 Right
: Node_Type
) return Boolean
1243 return Left
< Right
.Element
;
1244 end Is_Less_Element_Node
;
1246 -----------------------
1247 -- Is_Less_Node_Node --
1248 -----------------------
1250 function Is_Less_Node_Node
(L
, R
: Node_Type
) return Boolean is
1252 return L
.Element
< R
.Element
;
1253 end Is_Less_Node_Node
;
1259 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean
1260 renames Set_Ops
.Set_Subset
;
1268 Process
: not null access procedure (Position
: Cursor
))
1270 procedure Process_Node
(Node
: Count_Type
);
1271 pragma Inline
(Process_Node
);
1273 procedure Local_Iterate
is
1274 new Tree_Operations
.Generic_Iteration
(Process_Node
);
1280 procedure Process_Node
(Node
: Count_Type
) is
1282 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1285 S : Set renames Container'Unrestricted_Access.all;
1286 B : Natural renames S.Busy;
1288 -- Start of processing for Iterate
1304 function Iterate (Container : Set)
1305 return Set_Iterator_Interfaces.Reversible_Iterator'class
1307 B : Natural renames Container'Unrestricted_Access.all.Busy;
1310 -- The value of the Node component influences the behavior of the First
1311 -- and Last selector functions of the iterator object. When the Node
1312 -- component is 0 (as is the case here), this means the iterator object
1313 -- was constructed without a start expression. This is a complete
1314 -- iterator, meaning that the iteration starts from the (logical)
1315 -- beginning of the sequence of items.
1317 -- Note: For a forward iterator, Container.First is the beginning, and
1318 -- for a reverse iterator, Container.Last is the beginning.
1320 return It : constant Iterator :=
1321 Iterator'(Limited_Controlled
with
1322 Container
=> Container
'Unrestricted_Access,
1329 function Iterate
(Container
: Set
; Start
: Cursor
)
1330 return Set_Iterator_Interfaces
.Reversible_Iterator
'class
1332 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
1335 -- It was formerly the case that when Start = No_Element, the partial
1336 -- iterator was defined to behave the same as for a complete iterator,
1337 -- and iterate over the entire sequence of items. However, those
1338 -- semantics were unintuitive and arguably error-prone (it is too easy
1339 -- to accidentally create an endless loop), and so they were changed,
1340 -- per the ARG meeting in Denver on 2011/11. However, there was no
1341 -- consensus about what positive meaning this corner case should have,
1342 -- and so it was decided to simply raise an exception. This does imply,
1343 -- however, that it is not possible to use a partial iterator to specify
1344 -- an empty sequence of items.
1346 if Start
= No_Element
then
1347 raise Constraint_Error
with
1348 "Start position for iterator equals No_Element";
1351 if Start
.Container
/= Container
'Unrestricted_Access then
1352 raise Program_Error
with
1353 "Start cursor of Iterate designates wrong set";
1356 pragma Assert
(Vet
(Container
, Start
.Node
),
1357 "Start cursor of Iterate is bad");
1359 -- The value of the Node component influences the behavior of the First
1360 -- and Last selector functions of the iterator object. When the Node
1361 -- component is positive (as is the case here), it means that this
1362 -- is a partial iteration, over a subset of the complete sequence of
1363 -- items. The iterator object was constructed with a start expression,
1364 -- indicating the position from which the iteration begins. (Note that
1365 -- the start position has the same value irrespective of whether this
1366 -- is a forward or reverse iteration.)
1368 return It
: constant Iterator
:=
1369 Iterator
'(Limited_Controlled with
1370 Container => Container'Unrestricted_Access,
1381 function Last (Container : Set) return Cursor is
1383 return (if Container.Last = 0 then No_Element
1384 else Cursor'(Container
'Unrestricted_Access, Container
.Last
));
1387 function Last
(Object
: Iterator
) return Cursor
is
1389 -- The value of the iterator object's Node component influences the
1390 -- behavior of the Last (and First) selector function.
1392 -- When the Node component is 0, this means the iterator object was
1393 -- constructed without a start expression, in which case the (reverse)
1394 -- iteration starts from the (logical) beginning of the entire sequence
1395 -- (corresponding to Container.Last, for a reverse iterator).
1397 -- Otherwise, this is iteration over a partial sequence of items. When
1398 -- the Node component is positive, the iterator object was constructed
1399 -- with a start expression, that specifies the position from which the
1400 -- (reverse) partial iteration begins.
1402 if Object
.Node
= 0 then
1403 return Bounded_Ordered_Sets
.Last
(Object
.Container
.all);
1405 return Cursor
'(Object.Container, Object.Node);
1413 function Last_Element (Container : Set) return Element_Type is
1415 if Container.Last = 0 then
1416 raise Constraint_Error with "set is empty";
1419 return Container.Nodes (Container.Last).Element;
1426 function Left (Node : Node_Type) return Count_Type is
1435 function Length (Container : Set) return Count_Type is
1437 return Container.Length;
1444 procedure Move (Target : in out Set; Source : in out Set) is
1446 if Target'Address = Source'Address then
1450 if Source.Busy > 0 then
1451 raise Program_Error with
1452 "attempt to tamper with cursors (container is busy)";
1455 Target.Assign (Source);
1463 function Next (Position : Cursor) return Cursor is
1465 if Position = No_Element then
1469 pragma Assert (Vet (Position.Container.all, Position.Node),
1470 "bad cursor in Next");
1473 Node : constant Count_Type :=
1474 Tree_Operations.Next (Position.Container.all, Position.Node);
1481 return Cursor'(Position
.Container
, Node
);
1485 procedure Next
(Position
: in out Cursor
) is
1487 Position
:= Next
(Position
);
1490 function Next
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
1492 if Position
.Container
= null then
1496 if Position
.Container
/= Object
.Container
then
1497 raise Program_Error
with
1498 "Position cursor of Next designates wrong set";
1501 return Next
(Position
);
1508 function Overlap
(Left
, Right
: Set
) return Boolean
1509 renames Set_Ops
.Set_Overlap
;
1515 function Parent
(Node
: Node_Type
) return Count_Type
is
1524 function Previous
(Position
: Cursor
) return Cursor
is
1526 if Position
= No_Element
then
1530 pragma Assert
(Vet
(Position
.Container
.all, Position
.Node
),
1531 "bad cursor in Previous");
1534 Node
: constant Count_Type
:=
1535 Tree_Operations
.Previous
(Position
.Container
.all, Position
.Node
);
1537 return (if Node
= 0 then No_Element
1538 else Cursor
'(Position.Container, Node));
1542 procedure Previous (Position : in out Cursor) is
1544 Position := Previous (Position);
1547 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1549 if Position.Container = null then
1553 if Position.Container /= Object.Container then
1554 raise Program_Error with
1555 "Position cursor of Previous designates wrong set";
1558 return Previous (Position);
1565 procedure Query_Element
1567 Process : not null access procedure (Element : Element_Type))
1570 if Position.Node = 0 then
1571 raise Constraint_Error with "Position cursor equals No_Element";
1574 pragma Assert (Vet (Position.Container.all, Position.Node),
1575 "bad cursor in Query_Element");
1578 S : Set renames Position.Container.all;
1579 B : Natural renames S.Busy;
1580 L : Natural renames S.Lock;
1587 Process (S.Nodes (Position.Node).Element);
1605 (Stream : not null access Root_Stream_Type'Class;
1606 Container : out Set)
1608 procedure Read_Element (Node : in out Node_Type);
1609 pragma Inline (Read_Element);
1611 procedure Allocate is
1612 new Tree_Operations.Generic_Allocate (Read_Element);
1614 procedure Read_Elements is
1615 new Tree_Operations.Generic_Read (Allocate);
1621 procedure Read_Element (Node : in out Node_Type) is
1623 Element_Type'Read (Stream, Node.Element);
1626 -- Start of processing for Read
1629 Read_Elements (Stream, Container);
1633 (Stream : not null access Root_Stream_Type'Class;
1637 raise Program_Error with "attempt to stream set cursor";
1641 (Stream : not null access Root_Stream_Type'Class;
1642 Item : out Constant_Reference_Type)
1645 raise Program_Error with "attempt to stream reference";
1652 procedure Replace (Container : in out Set; New_Item : Element_Type) is
1653 Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
1657 raise Constraint_Error with
1658 "attempt to replace element not in set";
1661 if Container.Lock > 0 then
1662 raise Program_Error with
1663 "attempt to tamper with elements (set is locked)";
1666 Container.Nodes (Node).Element := New_Item;
1669 ---------------------
1670 -- Replace_Element --
1671 ---------------------
1673 procedure Replace_Element
1674 (Container : in out Set;
1676 Item : Element_Type)
1678 pragma Assert (Index /= 0);
1680 function New_Node return Count_Type;
1681 pragma Inline (New_Node);
1683 procedure Local_Insert_Post is
1684 new Element_Keys.Generic_Insert_Post (New_Node);
1686 procedure Local_Insert_Sans_Hint is
1687 new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
1689 procedure Local_Insert_With_Hint is
1690 new Element_Keys.Generic_Conditional_Insert_With_Hint
1692 Local_Insert_Sans_Hint);
1694 Nodes : Nodes_Type renames Container.Nodes;
1695 Node : Node_Type renames Nodes (Index);
1701 function New_Node return Count_Type is
1703 Node.Element := Item;
1704 Node.Color := Red_Black_Trees.Red;
1712 Result : Count_Type;
1716 -- Per AI05-0022, the container implementation is required to detect
1717 -- element tampering by a generic actual subprogram.
1719 B : Natural renames Container.Busy;
1720 L : Natural renames Container.Lock;
1722 -- Start of processing for Replace_Element
1725 -- Replace_Element assigns value Item to the element designated by Node,
1726 -- per certain semantic constraints, described as follows.
1728 -- If Item is equivalent to the element, then element is replaced and
1729 -- there's nothing else to do. This is the easy case.
1731 -- If Item is not equivalent, then the node will (possibly) have to move
1732 -- to some other place in the tree. This is slighly more complicated,
1733 -- because we must ensure that Item is not equivalent to some other
1734 -- element in the tree (in which case, the replacement is not allowed).
1736 -- Determine whether Item is equivalent to element on the specified
1743 Compare := (if Item < Node.Element then False
1744 elsif Node.Element < Item then False
1759 -- Item is equivalent to the node's element, so we will not have to
1762 if Container.Lock > 0 then
1763 raise Program_Error with
1764 "attempt to tamper with elements (set is locked)";
1767 Node.Element := Item;
1771 -- The replacement Item is not equivalent to the element on the
1772 -- specified node, which means that it will need to be re-inserted in a
1773 -- different position in the tree. We must now determine whether Item is
1774 -- equivalent to some other element in the tree (which would prohibit
1775 -- the assignment and hence the move).
1777 -- Ceiling returns the smallest element equivalent or greater than the
1778 -- specified Item; if there is no such element, then it returns 0.
1780 Hint := Element_Keys.Ceiling (Container, Item);
1782 if Hint /= 0 then -- Item <= Nodes (Hint).Element
1787 Compare := Item < Nodes (Hint).Element;
1799 -- Item is equivalent to Nodes (Hint).Element
1803 -- Ceiling returns an element that is equivalent or greater than
1804 -- Item. If Item is "not less than" the element, then by
1805 -- elimination we know that Item is equivalent to the element.
1807 -- But this means that it is not possible to assign the value of
1808 -- Item to the specified element (on Node), because a different
1809 -- element (on Hint) equivalent to Item already exsits. (Were we
1810 -- to change Node's element value, we would have to move Node, but
1811 -- we would be unable to move the Node, because its new position
1812 -- in the tree is already occupied by an equivalent element.)
1814 raise Program_Error with "attempt to replace existing element";
1817 -- Item is not equivalent to any other element in the tree
1818 -- (specifically, it is less than Nodes (Hint).Element), so it is
1819 -- safe to assign the value of Item to Node.Element. This means that
1820 -- the node will have to move to a different position in the tree
1821 -- (because its element will have a different value).
1823 -- The nearest (greater) neighbor of Item is Hint. This will be the
1824 -- insertion position of Node (because its element will have Item as
1827 -- If Node equals Hint, the relative position of Node does not
1828 -- change. This allows us to perform an optimization: we need not
1829 -- remove Node from the tree and then reinsert it with its new value,
1830 -- because it would only be placed in the exact same position.
1832 if Hint = Index then
1833 if Container.Lock > 0 then
1834 raise Program_Error with
1835 "attempt to tamper with elements (set is locked)";
1838 Node.Element := Item;
1843 -- If we get here, it is because Item was greater than all elements in
1844 -- the tree (Hint = 0), or because Item was less than some element at a
1845 -- different place in the tree (Item < Nodes (Hint).Element and Hint /=
1846 -- Index). In either case, we remove Node from the tree and then insert
1847 -- Item into the tree, onto the same Node.
1849 Tree_Operations.Delete_Node_Sans_Free (Container, Index);
1851 Local_Insert_With_Hint
1856 Inserted => Inserted);
1858 pragma Assert (Inserted);
1859 pragma Assert (Result = Index);
1860 end Replace_Element;
1862 procedure Replace_Element
1863 (Container : in out Set;
1865 New_Item : Element_Type)
1868 if Position.Node = 0 then
1869 raise Constraint_Error with
1870 "Position cursor equals No_Element";
1873 if Position.Container /= Container'Unrestricted_Access then
1874 raise Program_Error with
1875 "Position cursor designates wrong set";
1878 pragma Assert (Vet (Container, Position.Node),
1879 "bad cursor in Replace_Element");
1881 Replace_Element (Container, Position.Node, New_Item);
1882 end Replace_Element;
1884 ---------------------
1885 -- Reverse_Iterate --
1886 ---------------------
1888 procedure Reverse_Iterate
1890 Process : not null access procedure (Position : Cursor))
1892 procedure Process_Node (Node : Count_Type);
1893 pragma Inline (Process_Node);
1895 procedure Local_Reverse_Iterate is
1896 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1902 procedure Process_Node (Node : Count_Type) is
1904 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1907 S
: Set
renames Container
'Unrestricted_Access.all;
1908 B
: Natural renames S
.Busy
;
1910 -- Start of processing for Reverse_Iterate
1916 Local_Reverse_Iterate
(S
);
1924 end Reverse_Iterate
;
1930 function Right
(Node
: Node_Type
) return Count_Type
is
1940 (Node
: in out Node_Type
;
1941 Color
: Red_Black_Trees
.Color_Type
)
1944 Node
.Color
:= Color
;
1951 procedure Set_Left
(Node
: in out Node_Type
; Left
: Count_Type
) is
1960 procedure Set_Parent
(Node
: in out Node_Type
; Parent
: Count_Type
) is
1962 Node
.Parent
:= Parent
;
1969 procedure Set_Right
(Node
: in out Node_Type
; Right
: Count_Type
) is
1971 Node
.Right
:= Right
;
1974 --------------------------
1975 -- Symmetric_Difference --
1976 --------------------------
1978 procedure Symmetric_Difference
(Target
: in out Set
; Source
: Set
)
1979 renames Set_Ops
.Set_Symmetric_Difference
;
1981 function Symmetric_Difference
(Left
, Right
: Set
) return Set
1982 renames Set_Ops
.Set_Symmetric_Difference
;
1988 function To_Set
(New_Item
: Element_Type
) return Set
is
1992 return S
: Set
(1) do
1993 Insert_Sans_Hint
(S
, New_Item
, Node
, Inserted
);
1994 pragma Assert
(Inserted
);
2002 procedure Union
(Target
: in out Set
; Source
: Set
)
2003 renames Set_Ops
.Set_Union
;
2005 function Union
(Left
, Right
: Set
) return Set
2006 renames Set_Ops
.Set_Union
;
2013 (Stream
: not null access Root_Stream_Type
'Class;
2016 procedure Write_Element
2017 (Stream
: not null access Root_Stream_Type
'Class;
2019 pragma Inline
(Write_Element
);
2021 procedure Write_Elements
is
2022 new Tree_Operations
.Generic_Write
(Write_Element
);
2028 procedure Write_Element
2029 (Stream
: not null access Root_Stream_Type
'Class;
2033 Element_Type
'Write (Stream
, Node
.Element
);
2036 -- Start of processing for Write
2039 Write_Elements
(Stream
, Container
);
2043 (Stream
: not null access Root_Stream_Type
'Class;
2047 raise Program_Error
with "attempt to stream set cursor";
2051 (Stream
: not null access Root_Stream_Type
'Class;
2052 Item
: Constant_Reference_Type
)
2055 raise Program_Error
with "attempt to stream reference";
2058 end Ada
.Containers
.Bounded_Ordered_Sets
;