1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS --
9 -- Copyright (C) 2004 Free Software Foundation, Inc. --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the contents of the part following the private keyword. --
15 -- GNAT is free software; you can redistribute it and/or modify it under --
16 -- terms of the GNU General Public License as published by the Free Soft- --
17 -- ware Foundation; either version 2, or (at your option) any later ver- --
18 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
21 -- for more details. You should have received a copy of the GNU General --
22 -- Public License distributed with GNAT; see file COPYING. If not, write --
23 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
24 -- MA 02111-1307, USA. --
26 -- As a special exception, if other files instantiate generics from this --
27 -- unit, or you link this unit with other files to produce an executable, --
28 -- this unit does not by itself cause the resulting executable to be --
29 -- covered by the GNU General Public License. This exception does not --
30 -- however invalidate any other reasons why the executable file might be --
31 -- covered by the GNU Public License. --
33 -- This unit was originally developed by Matthew J Heaney. --
34 ------------------------------------------------------------------------------
36 with Ada
.Containers
.Red_Black_Trees
.Generic_Operations
;
37 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Operations
);
39 with Ada
.Containers
.Red_Black_Trees
.Generic_Keys
;
40 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Keys
);
42 with Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
;
43 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
);
45 with Ada
.Unchecked_Deallocation
;
47 with System
; use type System
.Address
;
49 package body Ada
.Containers
.Indefinite_Ordered_Sets
is
51 type Element_Access
is access Element_Type
;
55 type Node_Type
is limited record
59 Color
: Red_Black_Trees
.Color_Type
:= Red
;
60 Element
: Element_Access
;
63 -----------------------
64 -- Local Subprograms --
65 -----------------------
67 function Color
(Node
: Node_Access
) return Color_Type
;
68 pragma Inline
(Color
);
70 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
71 pragma Inline
(Copy_Node
);
73 function Copy_Tree
(Source_Root
: Node_Access
) return Node_Access
;
75 procedure Delete_Tree
(X
: in out Node_Access
);
77 procedure Free
(X
: in out Node_Access
);
79 procedure Insert_With_Hint
80 (Dst_Tree
: in out Tree_Type
;
81 Dst_Hint
: Node_Access
;
82 Src_Node
: Node_Access
;
83 Dst_Node
: out Node_Access
);
85 function Is_Greater_Element_Node
87 Right
: Node_Access
) return Boolean;
88 pragma Inline
(Is_Greater_Element_Node
);
90 function Is_Less_Element_Node
92 Right
: Node_Access
) return Boolean;
93 pragma Inline
(Is_Less_Element_Node
);
95 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean;
96 pragma Inline
(Is_Less_Node_Node
);
98 function Left
(Node
: Node_Access
) return Node_Access
;
101 function Parent
(Node
: Node_Access
) return Node_Access
;
102 pragma Inline
(Parent
);
104 function Right
(Node
: Node_Access
) return Node_Access
;
105 pragma Inline
(Right
);
107 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
108 pragma Inline
(Set_Color
);
110 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
111 pragma Inline
(Set_Left
);
113 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
114 pragma Inline
(Set_Parent
);
116 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
117 pragma Inline
(Set_Right
);
119 --------------------------
120 -- Local Instantiations --
121 --------------------------
123 procedure Free_Element
is
124 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
126 package Tree_Operations
is
127 new Red_Black_Trees
.Generic_Operations
128 (Tree_Types
=> Tree_Types
,
129 Null_Node
=> Node_Access
'(null));
133 package Element_Keys is
134 new Red_Black_Trees.Generic_Keys
135 (Tree_Operations => Tree_Operations,
136 Key_Type => Element_Type,
137 Is_Less_Key_Node => Is_Less_Element_Node,
138 Is_Greater_Key_Node => Is_Greater_Element_Node);
141 new Generic_Set_Operations
142 (Tree_Operations => Tree_Operations,
143 Insert_With_Hint => Insert_With_Hint,
144 Copy_Tree => Copy_Tree,
145 Delete_Tree => Delete_Tree,
146 Is_Less => Is_Less_Node_Node,
153 function "<" (Left, Right : Cursor) return Boolean is
155 return Left.Node.Element.all < Right.Node.Element.all;
158 function "<" (Left : Cursor; Right : Element_Type) return Boolean is
160 return Left.Node.Element.all < Right;
163 function "<" (Left : Element_Type; Right : Cursor) return Boolean is
165 return Left < Right.Node.Element.all;
172 function "=" (Left, Right : Set) return Boolean is
174 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
175 pragma Inline (Is_Equal_Node_Node);
178 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
180 ------------------------
181 -- Is_Equal_Node_Node --
182 ------------------------
184 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
186 return L.Element.all = R.Element.all;
187 end Is_Equal_Node_Node;
189 -- Start of processing for "="
192 if Left'Address = Right'Address then
196 return Is_Equal (Left.Tree, Right.Tree);
204 function ">" (Left, Right : Cursor) return Boolean is
206 -- L > R same as R < L
208 return Right.Node.Element.all < Left.Node.Element.all;
211 function ">" (Left : Cursor; Right : Element_Type) return Boolean is
213 return Right < Left.Node.Element.all;
216 function ">" (Left : Element_Type; Right : Cursor) return Boolean is
218 return Right.Node.Element.all < Left;
225 procedure Adjust (Container : in out Set) is
226 Tree : Tree_Type renames Container.Tree;
229 if Tree.Length = 0 then
230 pragma Assert (Tree.Root = null);
235 Tree.Root := Copy_Tree (Tree.Root);
238 Tree := (Length => 0, others => null);
242 Tree.First := Min (Tree.Root);
243 Tree.Last := Max (Tree.Root);
250 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
251 Node : constant Node_Access :=
252 Element_Keys.Ceiling (Container.Tree, Item);
259 return Cursor'(Container
'Unchecked_Access, Node
);
266 procedure Clear
(Container
: in out Set
) is
267 Tree
: Tree_Type
renames Container
.Tree
;
268 Root
: Node_Access
:= Tree
.Root
;
270 Tree
:= (Length
=> 0, others => null);
278 function Color
(Node
: Node_Access
) return Color_Type
is
287 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean is
289 return Find
(Container
, Item
) /= No_Element
;
296 function Copy_Node
(Source
: Node_Access
) return Node_Access
is
297 Element
: Element_Access
:= new Element_Type
'(Source.Element.all);
299 return new Node_Type'(Parent
=> null,
302 Color
=> Source
.Color
,
306 Free_Element
(Element
);
314 function Copy_Tree
(Source_Root
: Node_Access
) return Node_Access
is
315 Target_Root
: Node_Access
:= Copy_Node
(Source_Root
);
319 if Source_Root
.Right
/= null then
320 Target_Root
.Right
:= Copy_Tree
(Source_Root
.Right
);
321 Target_Root
.Right
.Parent
:= Target_Root
;
325 X
:= Source_Root
.Left
;
329 Y
: Node_Access
:= Copy_Node
(X
);
335 if X
.Right
/= null then
336 Y
.Right
:= Copy_Tree
(X
.Right
);
349 Delete_Tree
(Target_Root
);
357 procedure Delete
(Container
: in out Set
; Position
: in out Cursor
) is
359 if Position
= No_Element
then
363 if Position
.Container
/= Set_Access
'(Container'Unchecked_Access) then
367 Delete_Node_Sans_Free (Container.Tree, Position.Node);
368 Free (Position.Node);
370 Position.Container := null;
373 procedure Delete (Container : in out Set; Item : Element_Type) is
375 Element_Keys.Find (Container.Tree, Item);
379 raise Constraint_Error;
382 Delete_Node_Sans_Free (Container.Tree, X);
390 procedure Delete_First (Container : in out Set) is
391 C : Cursor := First (Container);
393 Delete (Container, C);
400 procedure Delete_Last (Container : in out Set) is
401 C : Cursor := Last (Container);
403 Delete (Container, C);
410 procedure Delete_Tree (X : in out Node_Access) is
426 procedure Difference (Target : in out Set; Source : Set) is
428 if Target'Address = Source'Address then
433 Set_Ops.Difference (Target.Tree, Source.Tree);
436 function Difference (Left, Right : Set) return Set is
438 if Left'Address = Right'Address then
443 Tree : constant Tree_Type :=
444 Set_Ops.Difference (Left.Tree, Right.Tree);
446 return (Controlled with Tree);
454 function Element (Position : Cursor) return Element_Type is
456 return Position.Node.Element.all;
463 procedure Exclude (Container : in out Set; Item : Element_Type) is
465 Element_Keys.Find (Container.Tree, Item);
468 Delete_Node_Sans_Free (Container.Tree, X);
477 function Find (Container : Set; Item : Element_Type) return Cursor is
478 Node : constant Node_Access :=
479 Element_Keys.Find (Container.Tree, Item);
486 return Cursor'(Container
'Unchecked_Access, Node
);
493 function First
(Container
: Set
) return Cursor
is
495 if Container
.Tree
.First
= null then
499 return Cursor
'(Container'Unchecked_Access, Container.Tree.First);
506 function First_Element (Container : Set) return Element_Type is
508 return Container.Tree.First.Element.all;
515 function Floor (Container : Set; Item : Element_Type) return Cursor is
516 Node : constant Node_Access :=
517 Element_Keys.Floor (Container.Tree, Item);
524 return Cursor'(Container
'Unchecked_Access, Node
);
531 procedure Free
(X
: in out Node_Access
) is
532 procedure Deallocate
is
533 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
536 Free_Element
(X
.Element
);
545 package body Generic_Keys
is
547 -----------------------
548 -- Local Subprograms --
549 -----------------------
551 function Is_Greater_Key_Node
553 Right
: Node_Access
) return Boolean;
554 pragma Inline
(Is_Greater_Key_Node
);
556 function Is_Less_Key_Node
558 Right
: Node_Access
) return Boolean;
559 pragma Inline
(Is_Less_Key_Node
);
561 --------------------------
562 -- Local Instantiations --
563 --------------------------
566 new Red_Black_Trees
.Generic_Keys
567 (Tree_Operations
=> Tree_Operations
,
568 Key_Type
=> Key_Type
,
569 Is_Less_Key_Node
=> Is_Less_Key_Node
,
570 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
576 function "<" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
578 return Left
< Right
.Node
.Element
.all;
581 function "<" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
583 return Right
> Left
.Node
.Element
.all;
590 function ">" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
592 return Left
> Right
.Node
.Element
.all;
595 function ">" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
597 return Right
< Left
.Node
.Element
.all;
604 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
is
605 Node
: constant Node_Access
:=
606 Key_Keys
.Ceiling
(Container
.Tree
, Key
);
613 return Cursor
'(Container'Unchecked_Access, Node);
616 ----------------------------
617 -- Checked_Update_Element --
618 ----------------------------
620 procedure Checked_Update_Element
621 (Container : in out Set;
623 Process : not null access
624 procedure (Element : in out Element_Type))
627 if Position.Container = null then
628 raise Constraint_Error;
631 if Position.Container /= Set_Access'(Container
'Unchecked_Access) then
636 Old_Key
: Key_Type
renames Key
(Position
.Node
.Element
.all);
639 Process
(Position
.Node
.Element
.all);
641 if Old_Key
< Position
.Node
.Element
.all
642 or else Old_Key
> Position
.Node
.Element
.all
651 Result
: Node_Access
;
654 function New_Node
return Node_Access
;
655 pragma Inline
(New_Node
);
657 procedure Insert_Post
is
658 new Key_Keys
.Generic_Insert_Post
(New_Node
);
661 new Key_Keys
.Generic_Conditional_Insert
(Insert_Post
);
667 function New_Node
return Node_Access
is
669 return Position
.Node
;
672 -- Start of processing for Checked_Update_Element
675 Delete_Node_Sans_Free
(Container
.Tree
, Position
.Node
);
678 (Tree
=> Container
.Tree
,
679 Key
=> Key
(Position
.Node
.Element
.all),
685 X
: Node_Access
:= Position
.Node
;
693 pragma Assert
(Result
= Position
.Node
);
695 end Checked_Update_Element
;
701 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean is
703 return Find
(Container
, Key
) /= No_Element
;
710 procedure Delete
(Container
: in out Set
; Key
: Key_Type
) is
711 X
: Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
715 raise Constraint_Error
;
718 Delete_Node_Sans_Free
(Container
.Tree
, X
);
726 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
is
727 C
: constant Cursor
:= Find
(Container
, Key
);
729 return C
.Node
.Element
.all;
736 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
) is
737 X
: Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
741 Delete_Node_Sans_Free
(Container
.Tree
, X
);
750 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
is
751 Node
: constant Node_Access
:=
752 Key_Keys
.Find
(Container
.Tree
, Key
);
759 return Cursor
'(Container'Unchecked_Access, Node);
766 function Floor (Container : Set; Key : Key_Type) return Cursor is
767 Node : constant Node_Access :=
768 Key_Keys.Floor (Container.Tree, Key);
775 return Cursor'(Container
'Unchecked_Access, Node
);
778 -------------------------
779 -- Is_Greater_Key_Node --
780 -------------------------
782 function Is_Greater_Key_Node
784 Right
: Node_Access
) return Boolean is
786 return Left
> Right
.Element
.all;
787 end Is_Greater_Key_Node
;
789 ----------------------
790 -- Is_Less_Key_Node --
791 ----------------------
793 function Is_Less_Key_Node
795 Right
: Node_Access
) return Boolean is
797 return Left
< Right
.Element
.all;
798 end Is_Less_Key_Node
;
804 function Key
(Position
: Cursor
) return Key_Type
is
806 return Key
(Position
.Node
.Element
.all);
815 function Has_Element
(Position
: Cursor
) return Boolean is
817 return Position
/= No_Element
;
824 procedure Include
(Container
: in out Set
; New_Item
: Element_Type
) is
831 Insert
(Container
, New_Item
, Position
, Inserted
);
834 X
:= Position
.Node
.Element
;
835 Position
.Node
.Element
:= new Element_Type
'(New_Item);
845 (Container : in out Set;
846 New_Item : Element_Type;
847 Position : out Cursor;
848 Inserted : out Boolean)
850 function New_Node return Node_Access;
851 pragma Inline (New_Node);
853 procedure Insert_Post is
854 new Element_Keys.Generic_Insert_Post (New_Node);
856 procedure Insert_Sans_Hint is
857 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
863 function New_Node return Node_Access is
864 Element : Element_Access := new Element_Type'(New_Item
);
866 return new Node_Type
'(Parent => null,
873 Free_Element (Element);
877 -- Start of processing for Insert
886 Position.Container := Container'Unchecked_Access;
889 procedure Insert (Container : in out Set; New_Item : Element_Type) is
893 Insert (Container, New_Item, Position, Inserted);
896 raise Constraint_Error;
900 ----------------------
901 -- Insert_With_Hint --
902 ----------------------
904 procedure Insert_With_Hint
905 (Dst_Tree : in out Tree_Type;
906 Dst_Hint : Node_Access;
907 Src_Node : Node_Access;
908 Dst_Node : out Node_Access)
912 function New_Node return Node_Access;
914 procedure Insert_Post is
915 new Element_Keys.Generic_Insert_Post (New_Node);
917 procedure Insert_Sans_Hint is
918 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
920 procedure Insert_With_Hint is
921 new Element_Keys.Generic_Conditional_Insert_With_Hint
929 function New_Node return Node_Access is
930 Element : Element_Access :=
931 new Element_Type'(Src_Node
.Element
.all);
936 Node
:= new Node_Type
;
939 Free_Element
(Element
);
943 Node
.Element
:= Element
;
947 -- Start of processing for Insert_With_Hint
953 Src_Node
.Element
.all,
956 end Insert_With_Hint
;
962 procedure Intersection
(Target
: in out Set
; Source
: Set
) is
964 if Target
'Address = Source
'Address then
968 Set_Ops
.Intersection
(Target
.Tree
, Source
.Tree
);
971 function Intersection
(Left
, Right
: Set
) return Set
is
973 if Left
'Address = Right
'Address then
978 Tree
: constant Tree_Type
:=
979 Set_Ops
.Intersection
(Left
.Tree
, Right
.Tree
);
981 return (Controlled
with Tree
);
989 function Is_Empty
(Container
: Set
) return Boolean is
991 return Length
(Container
) = 0;
994 -----------------------------
995 -- Is_Greater_Element_Node --
996 -----------------------------
998 function Is_Greater_Element_Node
999 (Left
: Element_Type
;
1000 Right
: Node_Access
) return Boolean is
1002 -- e > node same as node < e
1004 return Right
.Element
.all < Left
;
1005 end Is_Greater_Element_Node
;
1008 --------------------------
1009 -- Is_Less_Element_Node --
1010 --------------------------
1012 function Is_Less_Element_Node
1013 (Left
: Element_Type
;
1014 Right
: Node_Access
) return Boolean is
1016 return Left
< Right
.Element
.all;
1017 end Is_Less_Element_Node
;
1019 -----------------------
1020 -- Is_Less_Node_Node --
1021 -----------------------
1023 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean is
1025 return L
.Element
.all < R
.Element
.all;
1026 end Is_Less_Node_Node
;
1032 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
1034 if Subset
'Address = Of_Set
'Address then
1038 return Set_Ops
.Is_Subset
(Subset
=> Subset
.Tree
, Of_Set
=> Of_Set
.Tree
);
1047 Process
: not null access procedure (Position
: Cursor
))
1049 procedure Process_Node
(Node
: Node_Access
);
1050 pragma Inline
(Process_Node
);
1052 procedure Local_Iterate
is
1053 new Tree_Operations
.Generic_Iteration
(Process_Node
);
1059 procedure Process_Node
(Node
: Node_Access
) is
1061 Process
(Cursor
'(Container'Unchecked_Access, Node));
1064 -- Start of processing for Iterate
1067 Local_Iterate (Container.Tree);
1074 function Last (Container : Set) return Cursor is
1076 if Container.Tree.Last = null then
1080 return Cursor'(Container
'Unchecked_Access, Container
.Tree
.Last
);
1087 function Last_Element
(Container
: Set
) return Element_Type
is
1089 return Container
.Tree
.Last
.Element
.all;
1096 function Left
(Node
: Node_Access
) return Node_Access
is
1105 function Length
(Container
: Set
) return Count_Type
is
1107 return Container
.Tree
.Length
;
1114 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1116 if Target
'Address = Source
'Address then
1120 Move
(Target
=> Target
.Tree
, Source
=> Source
.Tree
);
1127 procedure Next
(Position
: in out Cursor
) is
1129 Position
:= Next
(Position
);
1132 function Next
(Position
: Cursor
) return Cursor
is
1134 if Position
= No_Element
then
1139 Node
: constant Node_Access
:=
1140 Tree_Operations
.Next
(Position
.Node
);
1146 return Cursor
'(Position.Container, Node);
1154 function Overlap (Left, Right : Set) return Boolean is
1156 if Left'Address = Right'Address then
1157 return Left.Tree.Length /= 0;
1160 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1167 function Parent (Node : Node_Access) return Node_Access is
1176 procedure Previous (Position : in out Cursor) is
1178 Position := Previous (Position);
1181 function Previous (Position : Cursor) return Cursor is
1183 if Position = No_Element then
1188 Node : constant Node_Access :=
1189 Tree_Operations.Previous (Position.Node);
1195 return Cursor'(Position
.Container
, Node
);
1203 procedure Query_Element
1205 Process
: not null access procedure (Element
: Element_Type
))
1208 Process
(Position
.Node
.Element
.all);
1216 (Stream
: access Ada
.Streams
.Root_Stream_Type
'Class;
1217 Container
: out Set
)
1219 N
: Count_Type
'Base;
1221 function New_Node
return Node_Access
;
1224 new Tree_Operations
.Generic_Read
(New_Node
);
1230 function New_Node
return Node_Access
is
1231 Node
: Node_Access
:= new Node_Type
;
1234 Node
.Element
:= new Element_Type
'(Element_Type'Input (Stream));
1243 -- Start of processing for Read
1247 Count_Type'Base'Read
(Stream
, N
);
1248 pragma Assert
(N
>= 0);
1249 Read
(Container
.Tree
, N
);
1256 procedure Replace
(Container
: in out Set
; New_Item
: Element_Type
) is
1257 Node
: constant Node_Access
:=
1258 Element_Keys
.Find
(Container
.Tree
, New_Item
);
1264 raise Constraint_Error
;
1268 Node
.Element
:= new Element_Type
'(New_Item);
1273 -- procedure Replace
1274 -- (Container : in out Set;
1276 -- New_Item : Element_Type)
1278 -- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
1281 -- if Node = null then
1282 -- raise Constraint_Error;
1285 -- Replace_Element (Container, Node, New_Item);
1288 ---------------------
1289 -- Replace_Element --
1290 ---------------------
1293 -- procedure Replace_Element
1294 -- (Container : in out Set;
1295 -- Position : Node_Access;
1296 -- By : Element_Type)
1299 -- Node : Node_Access := Position;
1302 -- if By < Node.Element.all
1303 -- or else Node.Element.all < By
1309 -- X : Element_Access := Node.Element;
1312 -- Node.Element := new Element_Type'(By
);
1314 -- -- NOTE: If there's an exception here, then just
1315 -- -- let it propagate. We haven't modified the
1316 -- -- state of the container, so there's nothing else
1317 -- -- we need to do.
1319 -- Free_Element (X);
1325 -- Delete_Node_Sans_Free (Container.Tree, Node);
1328 -- Free_Element (Node.Element);
1331 -- Node.Element := null; -- don't attempt to dealloc X.E again
1337 -- Node.Element := new Element_Type'(By);
1345 -- function New_Node return Node_Access;
1346 -- pragma Inline (New_Node);
1348 -- function New_Node return Node_Access is
1353 -- procedure Insert_Post is
1354 -- new Element_Keys.Generic_Insert_Post (New_Node);
1356 -- procedure Insert is
1357 -- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1359 -- Result : Node_Access;
1360 -- Success : Boolean;
1364 -- (Tree => Container.Tree,
1365 -- Key => Node.Element.all,
1367 -- Success => Success);
1369 -- if not Success then
1371 -- raise Program_Error;
1374 -- pragma Assert (Result = Node);
1376 -- end Replace_Element;
1379 -- procedure Replace_Element
1380 -- (Container : in out Set;
1381 -- Position : Cursor;
1382 -- By : Element_Type)
1385 -- if Position.Container = null then
1386 -- raise Constraint_Error;
1389 -- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
1390 -- raise Program_Error;
1393 -- Replace_Element (Container, Position.Node, By);
1394 -- end Replace_Element;
1396 ---------------------
1397 -- Reverse_Iterate --
1398 ---------------------
1400 procedure Reverse_Iterate
1402 Process
: not null access procedure (Position
: Cursor
))
1404 procedure Process_Node
(Node
: Node_Access
);
1405 pragma Inline
(Process_Node
);
1407 procedure Local_Reverse_Iterate
is
1408 new Tree_Operations
.Generic_Reverse_Iteration
(Process_Node
);
1414 procedure Process_Node
(Node
: Node_Access
) is
1416 Process
(Cursor
'(Container'Unchecked_Access, Node));
1419 -- Start of processing for Reverse_Iterate
1422 Local_Reverse_Iterate (Container.Tree);
1423 end Reverse_Iterate;
1429 function Right (Node : Node_Access) return Node_Access is
1438 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1440 Node.Color := Color;
1447 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1456 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1458 Node.Parent := Parent;
1465 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1467 Node.Right := Right;
1470 --------------------------
1471 -- Symmetric_Difference --
1472 --------------------------
1474 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1476 if Target'Address = Source'Address then
1481 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1482 end Symmetric_Difference;
1484 function Symmetric_Difference (Left, Right : Set) return Set is
1486 if Left'Address = Right'Address then
1491 Tree : constant Tree_Type :=
1492 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1494 return (Controlled with Tree);
1496 end Symmetric_Difference;
1502 procedure Union (Target : in out Set; Source : Set) is
1504 if Target'Address = Source'Address then
1508 Set_Ops.Union (Target.Tree, Source.Tree);
1511 function Union (Left, Right : Set) return Set is
1513 if Left'Address = Right'Address then
1518 Tree : constant Tree_Type :=
1519 Set_Ops.Union (Left.Tree, Right.Tree);
1521 return (Controlled with Tree);
1530 (Stream : access Ada.Streams.Root_Stream_Type'Class;
1533 procedure Process (Node : Node_Access);
1534 pragma Inline (Process);
1536 procedure Iterate is
1537 new Tree_Operations.Generic_Iteration (Process);
1543 procedure Process (Node : Node_Access) is
1545 Element_Type'Output (Stream, Node.Element.all);
1548 -- Start of processing for Write
1551 Count_Type'Base'Write
(Stream
, Container
.Tree
.Length
);
1552 Iterate
(Container
.Tree
);
1555 end Ada
.Containers
.Indefinite_Ordered_Sets
;