1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS --
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
.Unchecked_Deallocation
;
38 with Ada
.Containers
.Red_Black_Trees
.Generic_Operations
;
39 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Operations
);
41 with Ada
.Containers
.Red_Black_Trees
.Generic_Keys
;
42 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Keys
);
44 with Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
;
45 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
);
47 with System
; use type System
.Address
;
49 package body Ada
.Containers
.Indefinite_Ordered_Multisets
is
53 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 -- Node Access Subprograms --
65 -----------------------------
67 -- These subprograms provide a functional interface to access fields
68 -- of a node, and a procedural interface for modifying these values.
70 function Color
(Node
: Node_Access
) return Color_Type
;
71 pragma Inline
(Color
);
73 function Left
(Node
: Node_Access
) return Node_Access
;
76 function Parent
(Node
: Node_Access
) return Node_Access
;
77 pragma Inline
(Parent
);
79 function Right
(Node
: Node_Access
) return Node_Access
;
80 pragma Inline
(Right
);
82 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
83 pragma Inline
(Set_Parent
);
85 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
86 pragma Inline
(Set_Left
);
88 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
89 pragma Inline
(Set_Right
);
91 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
92 pragma Inline
(Set_Color
);
94 -----------------------
95 -- Local Subprograms --
96 -----------------------
98 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
99 pragma Inline
(Copy_Node
);
101 function Copy_Tree
(Source_Root
: Node_Access
) return Node_Access
;
103 procedure Delete_Tree
(X
: in out Node_Access
);
105 procedure Free
(X
: in out Node_Access
);
107 procedure Insert_With_Hint
108 (Dst_Tree
: in out Tree_Type
;
109 Dst_Hint
: Node_Access
;
110 Src_Node
: Node_Access
;
111 Dst_Node
: out Node_Access
);
113 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean;
114 pragma Inline
(Is_Equal_Node_Node
);
116 function Is_Greater_Element_Node
117 (Left
: Element_Type
;
118 Right
: Node_Access
) return Boolean;
119 pragma Inline
(Is_Greater_Element_Node
);
121 function Is_Less_Element_Node
122 (Left
: Element_Type
;
123 Right
: Node_Access
) return Boolean;
124 pragma Inline
(Is_Less_Element_Node
);
126 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean;
127 pragma Inline
(Is_Less_Node_Node
);
129 --------------------------
130 -- Local Instantiations --
131 --------------------------
133 package Tree_Operations
is
134 new Red_Black_Trees
.Generic_Operations
135 (Tree_Types
=> Tree_Types
,
136 Null_Node
=> Node_Access
'(null));
140 procedure Free_Element is
141 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
144 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
147 new Generic_Set_Operations
148 (Tree_Operations => Tree_Operations,
149 Insert_With_Hint => Insert_With_Hint,
150 Copy_Tree => Copy_Tree,
151 Delete_Tree => Delete_Tree,
152 Is_Less => Is_Less_Node_Node,
155 package Element_Keys is
156 new Red_Black_Trees.Generic_Keys
157 (Tree_Operations => Tree_Operations,
158 Key_Type => Element_Type,
159 Is_Less_Key_Node => Is_Less_Element_Node,
160 Is_Greater_Key_Node => Is_Greater_Element_Node);
166 function "<" (Left, Right : Cursor) return Boolean is
168 return Left.Node.Element.all < Right.Node.Element.all;
171 function "<" (Left : Cursor; Right : Element_Type) return Boolean is
173 return Left.Node.Element.all < Right;
176 function "<" (Left : Element_Type; Right : Cursor) return Boolean is
178 return Left < Right.Node.Element.all;
185 function "=" (Left, Right : Set) return Boolean is begin
186 if Left'Address = Right'Address then
190 return Is_Equal (Left.Tree, Right.Tree);
197 function ">" (Left : Cursor; Right : Element_Type) return Boolean is
199 return Right < Left.Node.Element.all;
202 function ">" (Left, Right : Cursor) return Boolean is
204 -- L > R same as R < L
206 return Right.Node.Element.all < Left.Node.Element.all;
209 function ">" (Left : Element_Type; Right : Cursor) return Boolean is
211 return Right.Node.Element.all < Left;
218 procedure Adjust (Container : in out Set) is
219 Tree : Tree_Type renames Container.Tree;
221 N : constant Count_Type := Tree.Length;
222 X : constant Node_Access := Tree.Root;
226 pragma Assert (X = null);
230 Tree := (Length => 0, others => null);
232 Tree.Root := Copy_Tree (X);
233 Tree.First := Min (Tree.Root);
234 Tree.Last := Max (Tree.Root);
242 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
243 Node : constant Node_Access :=
244 Element_Keys.Ceiling (Container.Tree, Item);
251 return Cursor'(Container
'Unchecked_Access, Node
);
258 procedure Clear
(Container
: in out Set
) is
259 Tree
: Tree_Type
renames Container
.Tree
;
260 Root
: Node_Access
:= Tree
.Root
;
262 Tree
:= (Length
=> 0, others => null);
270 function Color
(Node
: Node_Access
) return Color_Type
is
279 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean is
281 return Find
(Container
, Item
) /= No_Element
;
288 function Copy_Node
(Source
: Node_Access
) return Node_Access
is
289 X
: Element_Access
:= new Element_Type
'(Source.Element.all);
292 return new Node_Type'(Parent
=> null,
295 Color
=> Source
.Color
,
308 function Copy_Tree
(Source_Root
: Node_Access
) return Node_Access
is
309 Target_Root
: Node_Access
:= Copy_Node
(Source_Root
);
314 if Source_Root
.Right
/= null then
315 Target_Root
.Right
:= Copy_Tree
(Source_Root
.Right
);
316 Target_Root
.Right
.Parent
:= Target_Root
;
320 X
:= Source_Root
.Left
;
323 Y
: Node_Access
:= Copy_Node
(X
);
329 if X
.Right
/= null then
330 Y
.Right
:= Copy_Tree
(X
.Right
);
343 Delete_Tree
(Target_Root
);
351 procedure Delete
(Container
: in out Set
; Item
: Element_Type
) is
352 Tree
: Tree_Type
renames Container
.Tree
;
353 Node
: Node_Access
:= Element_Keys
.Ceiling
(Tree
, Item
);
354 Done
: constant Node_Access
:= Element_Keys
.Upper_Bound
(Tree
, Item
);
359 raise Constraint_Error
;
364 Node
:= Tree_Operations
.Next
(Node
);
365 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
368 exit when Node
= Done
;
372 procedure Delete
(Container
: in out Set
; Position
: in out Cursor
) is
374 if Position
= No_Element
then
378 if Position
.Container
/= Set_Access
'(Container'Unchecked_Access) then
382 Delete_Node_Sans_Free (Container.Tree, Position.Node);
383 Free (Position.Node);
385 Position.Container := null;
392 procedure Delete_First (Container : in out Set) is
393 Tree : Tree_Type renames Container.Tree;
394 X : Node_Access := Tree.First;
401 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
409 procedure Delete_Last (Container : in out Set) is
410 Tree : Tree_Type renames Container.Tree;
411 X : Node_Access := Tree.Last;
418 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
426 procedure Delete_Tree (X : in out Node_Access) is
442 procedure Difference (Target : in out Set; Source : Set) is
444 if Target'Address = Source'Address then
449 Set_Ops.Difference (Target.Tree, Source.Tree);
452 function Difference (Left, Right : Set) return Set is
454 if Left'Address = Right'Address then
459 Tree : constant Tree_Type :=
460 Set_Ops.Difference (Left.Tree, Right.Tree);
462 return (Controlled with Tree);
470 function Element (Position : Cursor) return Element_Type is
472 return Position.Node.Element.all;
479 procedure Exclude (Container : in out Set; Item : Element_Type) is
480 Tree : Tree_Type renames Container.Tree;
481 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
482 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
485 while Node /= Done loop
487 Node := Tree_Operations.Next (Node);
488 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
497 function Find (Container : Set; Item : Element_Type) return Cursor is
498 Node : constant Node_Access :=
499 Element_Keys.Find (Container.Tree, Item);
506 return Cursor'(Container
'Unchecked_Access, Node
);
513 function First
(Container
: Set
) return Cursor
is
515 if Container
.Tree
.First
= null then
519 return Cursor
'(Container'Unchecked_Access, Container.Tree.First);
526 function First_Element (Container : Set) return Element_Type is
528 return Container.Tree.First.Element.all;
535 function Floor (Container : Set; Item : Element_Type) return Cursor is
536 Node : constant Node_Access :=
537 Element_Keys.Floor (Container.Tree, Item);
544 return Cursor'(Container
'Unchecked_Access, Node
);
551 procedure Free
(X
: in out Node_Access
) is
552 procedure Deallocate
is
553 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
556 Free_Element
(X
.Element
);
565 package body Generic_Keys
is
567 -----------------------
568 -- Local Subprograms --
569 -----------------------
571 function Is_Less_Key_Node
573 Right
: Node_Access
) return Boolean;
574 pragma Inline
(Is_Less_Key_Node
);
576 function Is_Greater_Key_Node
578 Right
: Node_Access
) return Boolean;
579 pragma Inline
(Is_Greater_Key_Node
);
581 --------------------------
582 -- Local Instantiations --
583 --------------------------
586 new Red_Black_Trees
.Generic_Keys
587 (Tree_Operations
=> Tree_Operations
,
588 Key_Type
=> Key_Type
,
589 Is_Less_Key_Node
=> Is_Less_Key_Node
,
590 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
596 function "<" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
598 return Left
< Right
.Node
.Element
.all;
601 function "<" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
603 return Right
> Left
.Node
.Element
.all;
610 function ">" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
612 return Left
> Right
.Node
.Element
.all;
615 function ">" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
617 return Right
< Left
.Node
.Element
.all;
624 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
is
625 Node
: constant Node_Access
:=
626 Key_Keys
.Ceiling
(Container
.Tree
, Key
);
633 return Cursor
'(Container'Unchecked_Access, Node);
636 ----------------------------
637 -- Checked_Update_Element --
638 ----------------------------
640 procedure Checked_Update_Element
641 (Container : in out Set;
643 Process : not null access procedure (Element : in out Element_Type))
646 if Position.Container = null then
647 raise Constraint_Error;
650 if Position.Container /= Set_Access'(Container
'Unchecked_Access) then
655 Old_Key
: Key_Type
renames Key
(Position
.Node
.Element
.all);
658 Process
(Position
.Node
.Element
.all);
660 if Old_Key
< Position
.Node
.Element
.all
661 or else Old_Key
> Position
.Node
.Element
.all
669 Delete_Node_Sans_Free
(Container
.Tree
, Position
.Node
);
672 Result
: Node_Access
;
674 function New_Node
return Node_Access
;
675 pragma Inline
(New_Node
);
677 procedure Insert_Post
is
678 new Key_Keys
.Generic_Insert_Post
(New_Node
);
681 new Key_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
687 function New_Node
return Node_Access
is
689 return Position
.Node
;
692 -- Start of processing for Do_Insert
696 (Tree
=> Container
.Tree
,
697 Key
=> Key
(Position
.Node
.Element
.all),
700 pragma Assert
(Result
= Position
.Node
);
702 end Checked_Update_Element
;
708 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean is
710 return Find
(Container
, Key
) /= No_Element
;
717 procedure Delete
(Container
: in out Set
; Key
: Key_Type
) is
718 Tree
: Tree_Type
renames Container
.Tree
;
719 Node
: Node_Access
:= Key_Keys
.Ceiling
(Tree
, Key
);
720 Done
: constant Node_Access
:= Key_Keys
.Upper_Bound
(Tree
, Key
);
725 raise Constraint_Error
;
730 Node
:= Tree_Operations
.Next
(Node
);
731 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
734 exit when Node
= Done
;
742 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
is
743 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
745 return Node
.Element
.all;
752 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
) is
753 Tree
: Tree_Type
renames Container
.Tree
;
754 Node
: Node_Access
:= Key_Keys
.Ceiling
(Tree
, Key
);
755 Done
: constant Node_Access
:= Key_Keys
.Upper_Bound
(Tree
, Key
);
759 while Node
/= Done
loop
761 Node
:= Tree_Operations
.Next
(Node
);
762 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, X
);
771 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
is
772 Node
: constant Node_Access
:= Key_Keys
.Find
(Container
.Tree
, Key
);
779 return Cursor
'(Container'Unchecked_Access, Node);
786 function Floor (Container : Set; Key : Key_Type) return Cursor is
787 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
794 return Cursor'(Container
'Unchecked_Access, Node
);
797 -------------------------
798 -- Is_Greater_Key_Node --
799 -------------------------
801 function Is_Greater_Key_Node
803 Right
: Node_Access
) return Boolean is
805 return Left
> Right
.Element
.all;
806 end Is_Greater_Key_Node
;
808 ----------------------
809 -- Is_Less_Key_Node --
810 ----------------------
812 function Is_Less_Key_Node
814 Right
: Node_Access
) return Boolean is
816 return Left
< Right
.Element
.all;
817 end Is_Less_Key_Node
;
826 Process
: not null access procedure (Position
: Cursor
))
828 procedure Process_Node
(Node
: Node_Access
);
829 pragma Inline
(Process_Node
);
831 procedure Local_Iterate
is
832 new Key_Keys
.Generic_Iteration
(Process_Node
);
838 procedure Process_Node
(Node
: Node_Access
) is
840 Process
(Cursor
'(Container'Unchecked_Access, Node));
843 -- Start of processing for Iterate
846 Local_Iterate (Container.Tree, Key);
853 function Key (Position : Cursor) return Key_Type is
855 return Key (Position.Node.Element.all);
862 -- In post-madision api: ???
865 -- (Container : in out Set;
867 -- New_Item : Element_Type)
869 -- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
872 -- if Node = null then
873 -- raise Constraint_Error;
876 -- Replace_Node (Container, Node, New_Item);
879 ---------------------
880 -- Reverse_Iterate --
881 ---------------------
883 procedure Reverse_Iterate
886 Process : not null access procedure (Position : Cursor))
888 procedure Process_Node (Node : Node_Access);
889 pragma Inline (Process_Node);
895 procedure Local_Reverse_Iterate is
896 new Key_Keys.Generic_Reverse_Iteration (Process_Node);
902 procedure Process_Node (Node : Node_Access) is
904 Process (Cursor'(Container
'Unchecked_Access, Node
));
907 -- Start of processing for Reverse_Iterate
910 Local_Reverse_Iterate
(Container
.Tree
, Key
);
919 function Has_Element
(Position
: Cursor
) return Boolean is
921 return Position
/= No_Element
;
928 procedure Insert
(Container
: in out Set
; New_Item
: Element_Type
) is
931 Insert
(Container
, New_Item
, Position
);
935 (Container
: in out Set
;
936 New_Item
: Element_Type
;
937 Position
: out Cursor
)
939 function New_Node
return Node_Access
;
940 pragma Inline
(New_Node
);
942 procedure Insert_Post
is
943 new Element_Keys
.Generic_Insert_Post
(New_Node
);
945 procedure Unconditional_Insert_Sans_Hint
is
946 new Element_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
952 function New_Node
return Node_Access
is
953 X
: Element_Access
:= new Element_Type
'(New_Item);
956 return new Node_Type'(Parent
=> null,
968 -- Start of processing for Insert
971 Unconditional_Insert_Sans_Hint
976 Position
.Container
:= Container
'Unchecked_Access;
979 ----------------------
980 -- Insert_With_Hint --
981 ----------------------
983 procedure Insert_With_Hint
984 (Dst_Tree
: in out Tree_Type
;
985 Dst_Hint
: Node_Access
;
986 Src_Node
: Node_Access
;
987 Dst_Node
: out Node_Access
)
989 function New_Node
return Node_Access
;
990 pragma Inline
(New_Node
);
992 procedure Insert_Post
is
993 new Element_Keys
.Generic_Insert_Post
(New_Node
);
995 procedure Insert_Sans_Hint
is
996 new Element_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
998 procedure Local_Insert_With_Hint
is
999 new Element_Keys
.Generic_Unconditional_Insert_With_Hint
1007 function New_Node
return Node_Access
is
1008 X
: Element_Access
:= new Element_Type
'(Src_Node.Element.all);
1011 return new Node_Type'(Parent
=> null,
1023 -- Start of processing for Insert_With_Hint
1026 Local_Insert_With_Hint
1029 Src_Node
.Element
.all,
1031 end Insert_With_Hint
;
1037 procedure Intersection
(Target
: in out Set
; Source
: Set
) is
1039 if Target
'Address = Source
'Address then
1043 Set_Ops
.Intersection
(Target
.Tree
, Source
.Tree
);
1046 function Intersection
(Left
, Right
: Set
) return Set
is
1048 if Left
'Address = Right
'Address then
1053 Tree
: constant Tree_Type
:=
1054 Set_Ops
.Intersection
(Left
.Tree
, Right
.Tree
);
1056 return (Controlled
with Tree
);
1064 function Is_Empty
(Container
: Set
) return Boolean is
1066 return Container
.Tree
.Length
= 0;
1069 ------------------------
1070 -- Is_Equal_Node_Node --
1071 ------------------------
1073 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean is
1075 return L
.Element
.all = R
.Element
.all;
1076 end Is_Equal_Node_Node
;
1078 -----------------------------
1079 -- Is_Greater_Element_Node --
1080 -----------------------------
1082 function Is_Greater_Element_Node
1083 (Left
: Element_Type
;
1084 Right
: Node_Access
) return Boolean
1087 -- e > node same as node < e
1089 return Right
.Element
.all < Left
;
1090 end Is_Greater_Element_Node
;
1092 --------------------------
1093 -- Is_Less_Element_Node --
1094 --------------------------
1096 function Is_Less_Element_Node
1097 (Left
: Element_Type
;
1098 Right
: Node_Access
) return Boolean
1101 return Left
< Right
.Element
.all;
1102 end Is_Less_Element_Node
;
1104 -----------------------
1105 -- Is_Less_Node_Node --
1106 -----------------------
1108 function Is_Less_Node_Node
(L
, R
: Node_Access
) return Boolean is
1110 return L
.Element
.all < R
.Element
.all;
1111 end Is_Less_Node_Node
;
1117 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
1119 if Subset
'Address = Of_Set
'Address then
1123 return Set_Ops
.Is_Subset
(Subset
=> Subset
.Tree
, Of_Set
=> Of_Set
.Tree
);
1132 Item
: Element_Type
;
1133 Process
: not null access procedure (Position
: Cursor
))
1135 procedure Process_Node
(Node
: Node_Access
);
1136 pragma Inline
(Process_Node
);
1138 procedure Local_Iterate
is
1139 new Element_Keys
.Generic_Iteration
(Process_Node
);
1145 procedure Process_Node
(Node
: Node_Access
) is
1147 Process
(Cursor
'(Container'Unchecked_Access, Node));
1150 -- Start of processing for Iterate
1153 Local_Iterate (Container.Tree, Item);
1158 Process : not null access procedure (Position : Cursor))
1160 procedure Process_Node (Node : Node_Access);
1161 pragma Inline (Process_Node);
1163 procedure Local_Iterate is
1164 new Tree_Operations.Generic_Iteration (Process_Node);
1170 procedure Process_Node (Node : Node_Access) is
1172 Process (Cursor'(Container
'Unchecked_Access, Node
));
1175 -- Start of processing for Iterate
1178 Local_Iterate
(Container
.Tree
);
1185 function Last
(Container
: Set
) return Cursor
is
1187 if Container
.Tree
.Last
= null then
1191 return Cursor
'(Container'Unchecked_Access, Container.Tree.Last);
1198 function Last_Element (Container : Set) return Element_Type is
1200 return Container.Tree.Last.Element.all;
1207 function Left (Node : Node_Access) return Node_Access is
1216 function Length (Container : Set) return Count_Type is
1218 return Container.Tree.Length;
1225 procedure Move (Target : in out Set; Source : in out Set) is
1227 if Target'Address = Source'Address then
1231 Move (Target => Target.Tree, Source => Source.Tree);
1238 function Next (Position : Cursor) return Cursor is
1240 if Position = No_Element then
1245 Node : constant Node_Access :=
1246 Tree_Operations.Next (Position.Node);
1253 return Cursor'(Position
.Container
, Node
);
1257 procedure Next
(Position
: in out Cursor
) is
1259 Position
:= Next
(Position
);
1266 function Overlap
(Left
, Right
: Set
) return Boolean is
1268 if Left
'Address = Right
'Address then
1269 return Left
.Tree
.Length
/= 0;
1272 return Set_Ops
.Overlap
(Left
.Tree
, Right
.Tree
);
1279 function Parent
(Node
: Node_Access
) return Node_Access
is
1288 function Previous
(Position
: Cursor
) return Cursor
is
1290 if Position
= No_Element
then
1295 Node
: constant Node_Access
:=
1296 Tree_Operations
.Previous
(Position
.Node
);
1303 return Cursor
'(Position.Container, Node);
1307 procedure Previous (Position : in out Cursor) is
1309 Position := Previous (Position);
1316 procedure Query_Element
1318 Process : not null access procedure (Element : Element_Type))
1321 Process (Position.Node.Element.all);
1329 (Stream : access Root_Stream_Type'Class;
1330 Container : out Set)
1332 N : Count_Type'Base;
1334 function New_Node return Node_Access;
1335 pragma Inline (New_Node);
1337 procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
1343 function New_Node return Node_Access is
1344 Node : Node_Access := new Node_Type;
1348 Node.Element := new Element_Type'(Element_Type
'Input (Stream
));
1358 -- Start of processing for Read
1363 Count_Type
'Base'Read (Stream, N);
1364 pragma Assert (N >= 0);
1366 Local_Read (Container.Tree, N);
1373 -- NOTE: from post-madison api???
1375 -- procedure Replace
1376 -- (Container : in out Set;
1377 -- Position : Cursor;
1378 -- By : Element_Type)
1381 -- if Position.Container = null then
1382 -- raise Constraint_Error;
1385 -- if Position.Container /= Set_Access'(Container
'Unchecked_Access) then
1386 -- raise Program_Error;
1389 -- Replace_Node (Container, Position.Node, By);
1396 -- NOTE: from post-madison api???
1398 -- procedure Replace_Node
1399 -- (Container : in out Set;
1400 -- Position : Node_Access;
1401 -- By : Element_Type);
1403 -- Tree : Tree_Type renames Container.Tree;
1404 -- Node : Node_Access := Position;
1407 -- if By < Node.Element
1408 -- or else Node.Element < By
1414 -- Node.Element := By;
1418 -- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
1426 -- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
1429 -- Node.Element := By;
1438 -- Result : Node_Access;
1439 -- Success : Boolean;
1441 -- function New_Node return Node_Access;
1442 -- pragma Inline (New_Node);
1444 -- procedure Insert_Post is
1445 -- new Element_Keys.Generic_Insert_Post (New_Node);
1447 -- procedure Insert is
1448 -- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1454 -- function New_Node return Node_Access is
1459 -- -- Start of processing for Replace_Node
1464 -- Key => Node.Element,
1466 -- Success => Success);
1468 -- if not Success then
1470 -- raise Program_Error;
1473 -- pragma Assert (Result = Node);
1475 -- end Replace_Node;
1477 ---------------------
1478 -- Reverse_Iterate --
1479 ---------------------
1481 procedure Reverse_Iterate
1483 Item
: Element_Type
;
1484 Process
: not null access procedure (Position
: Cursor
))
1486 procedure Process_Node
(Node
: Node_Access
);
1487 pragma Inline
(Process_Node
);
1489 procedure Local_Reverse_Iterate
is
1490 new Element_Keys
.Generic_Reverse_Iteration
(Process_Node
);
1496 procedure Process_Node
(Node
: Node_Access
) is
1498 Process
(Cursor
'(Container'Unchecked_Access, Node));
1501 -- Start of processing for Reverse_Iterate
1504 Local_Reverse_Iterate (Container.Tree, Item);
1505 end Reverse_Iterate;
1507 procedure Reverse_Iterate
1509 Process : not null access procedure (Position : Cursor))
1511 procedure Process_Node (Node : Node_Access);
1512 pragma Inline (Process_Node);
1514 procedure Local_Reverse_Iterate is
1515 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1521 procedure Process_Node (Node : Node_Access) is
1523 Process (Cursor'(Container
'Unchecked_Access, Node
));
1526 -- Start of processing for Reverse_Iterate
1529 Local_Reverse_Iterate
(Container
.Tree
);
1530 end Reverse_Iterate
;
1536 function Right
(Node
: Node_Access
) return Node_Access
is
1545 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
) is
1547 Node
.Color
:= Color
;
1554 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
) is
1563 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
) is
1565 Node
.Parent
:= Parent
;
1572 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
) is
1574 Node
.Right
:= Right
;
1577 --------------------------
1578 -- Symmetric_Difference --
1579 --------------------------
1581 procedure Symmetric_Difference
(Target
: in out Set
; Source
: Set
) is
1583 if Target
'Address = Source
'Address then
1588 Set_Ops
.Symmetric_Difference
(Target
.Tree
, Source
.Tree
);
1589 end Symmetric_Difference
;
1591 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
1593 if Left
'Address = Right
'Address then
1598 Tree
: constant Tree_Type
:=
1599 Set_Ops
.Symmetric_Difference
(Left
.Tree
, Right
.Tree
);
1601 return (Controlled
with Tree
);
1603 end Symmetric_Difference
;
1609 procedure Union
(Target
: in out Set
; Source
: Set
) is
1611 if Target
'Address = Source
'Address then
1615 Set_Ops
.Union
(Target
.Tree
, Source
.Tree
);
1618 function Union
(Left
, Right
: Set
) return Set
is begin
1619 if Left
'Address = Right
'Address then
1624 Tree
: constant Tree_Type
:= Set_Ops
.Union
(Left
.Tree
, Right
.Tree
);
1626 return (Controlled
with Tree
);
1635 (Stream
: access Root_Stream_Type
'Class;
1638 procedure Process
(Node
: Node_Access
);
1639 pragma Inline
(Process
);
1641 procedure Iterate
is new Tree_Operations
.Generic_Iteration
(Process
);
1647 procedure Process
(Node
: Node_Access
) is
1649 Element_Type
'Output (Stream
, Node
.Element
.all);
1652 -- Start of processing for Write
1655 Count_Type
'Base'Write (Stream, Container.Tree.Length);
1656 Iterate (Container.Tree);
1659 end Ada.Containers.Indefinite_Ordered_Multisets;