1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . O R D E R E D _ M A P S --
9 -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Unchecked_Deallocation
;
32 with Ada
.Containers
.Red_Black_Trees
.Generic_Operations
;
33 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Operations
);
35 with Ada
.Containers
.Red_Black_Trees
.Generic_Keys
;
36 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Keys
);
38 with System
; use type System
.Address
;
40 package body Ada
.Containers
.Ordered_Maps
is
42 pragma Annotate
(CodePeer
, Skip_Analysis
);
44 -----------------------------
45 -- Node Access Subprograms --
46 -----------------------------
48 -- These subprograms provide a functional interface to access fields
49 -- of a node, and a procedural interface for modifying these values.
51 function Color
(Node
: Node_Access
) return Color_Type
;
52 pragma Inline
(Color
);
54 function Left
(Node
: Node_Access
) return Node_Access
;
57 function Parent
(Node
: Node_Access
) return Node_Access
;
58 pragma Inline
(Parent
);
60 function Right
(Node
: Node_Access
) return Node_Access
;
61 pragma Inline
(Right
);
63 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
64 pragma Inline
(Set_Parent
);
66 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
67 pragma Inline
(Set_Left
);
69 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
70 pragma Inline
(Set_Right
);
72 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
73 pragma Inline
(Set_Color
);
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
79 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
80 pragma Inline
(Copy_Node
);
82 procedure Free
(X
: in out Node_Access
);
84 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean;
85 pragma Inline
(Is_Equal_Node_Node
);
87 function Is_Greater_Key_Node
89 Right
: Node_Access
) return Boolean;
90 pragma Inline
(Is_Greater_Key_Node
);
92 function Is_Less_Key_Node
94 Right
: Node_Access
) return Boolean;
95 pragma Inline
(Is_Less_Key_Node
);
97 --------------------------
98 -- Local Instantiations --
99 --------------------------
101 package Tree_Operations
is
102 new Red_Black_Trees
.Generic_Operations
(Tree_Types
);
104 procedure Delete_Tree
is
105 new Tree_Operations
.Generic_Delete_Tree
(Free
);
107 function Copy_Tree
is
108 new Tree_Operations
.Generic_Copy_Tree
(Copy_Node
, Delete_Tree
);
113 new Red_Black_Trees
.Generic_Keys
114 (Tree_Operations
=> Tree_Operations
,
115 Key_Type
=> Key_Type
,
116 Is_Less_Key_Node
=> Is_Less_Key_Node
,
117 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
120 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
126 function "<" (Left
, Right
: Cursor
) return Boolean is
128 if Left
.Node
= null then
129 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
132 if Right
.Node
= null then
133 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
136 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
137 "Left cursor of ""<"" is bad");
139 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
140 "Right cursor of ""<"" is bad");
142 return Left
.Node
.Key
< Right
.Node
.Key
;
145 function "<" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
147 if Left
.Node
= null then
148 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
151 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
152 "Left cursor of ""<"" is bad");
154 return Left
.Node
.Key
< Right
;
157 function "<" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
159 if Right
.Node
= null then
160 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
163 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
164 "Right cursor of ""<"" is bad");
166 return Left
< Right
.Node
.Key
;
173 function "=" (Left
, Right
: Map
) return Boolean is
175 return Is_Equal
(Left
.Tree
, Right
.Tree
);
182 function ">" (Left
, Right
: Cursor
) return Boolean is
184 if Left
.Node
= null then
185 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
188 if Right
.Node
= null then
189 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
192 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
193 "Left cursor of "">"" is bad");
195 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
196 "Right cursor of "">"" is bad");
198 return Right
.Node
.Key
< Left
.Node
.Key
;
201 function ">" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
203 if Left
.Node
= null then
204 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
207 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
208 "Left cursor of "">"" is bad");
210 return Right
< Left
.Node
.Key
;
213 function ">" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
215 if Right
.Node
= null then
216 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
219 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
220 "Right cursor of "">"" is bad");
222 return Right
.Node
.Key
< Left
;
230 new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
232 procedure Adjust
(Container
: in out Map
) is
234 Adjust
(Container
.Tree
);
237 procedure Adjust
(Control
: in out Reference_Control_Type
) is
239 if Control
.Container
/= null then
241 T
: Tree_Type
renames Control
.Container
.all.Tree
;
242 B
: Natural renames T
.Busy
;
243 L
: Natural renames T
.Lock
;
255 procedure Assign
(Target
: in out Map
; Source
: Map
) is
256 procedure Insert_Item
(Node
: Node_Access
);
257 pragma Inline
(Insert_Item
);
259 procedure Insert_Items
is
260 new Tree_Operations
.Generic_Iteration
(Insert_Item
);
266 procedure Insert_Item
(Node
: Node_Access
) is
268 Target
.Insert
(Key
=> Node
.Key
, New_Item
=> Node
.Element
);
271 -- Start of processing for Assign
274 if Target
'Address = Source
'Address then
279 Insert_Items
(Source
.Tree
);
286 function Ceiling
(Container
: Map
; Key
: Key_Type
) return Cursor
is
287 Node
: constant Node_Access
:= Key_Ops
.Ceiling
(Container
.Tree
, Key
);
294 return Cursor
'(Container'Unrestricted_Access, Node);
301 procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree);
303 procedure Clear (Container : in out Map) is
305 Clear (Container.Tree);
312 function Color (Node : Node_Access) return Color_Type is
317 ------------------------
318 -- Constant_Reference --
319 ------------------------
321 function Constant_Reference
322 (Container : aliased Map;
323 Position : Cursor) return Constant_Reference_Type
326 if Position.Container = null then
327 raise Constraint_Error with
328 "Position cursor has no element";
331 if Position.Container /= Container'Unrestricted_Access then
332 raise Program_Error with
333 "Position cursor designates wrong map";
336 pragma Assert (Vet (Container.Tree, Position.Node),
337 "Position cursor in Constant_Reference is bad");
340 T : Tree_Type renames Position.Container.all.Tree;
341 B : Natural renames T.Busy;
342 L : Natural renames T.Lock;
344 return R : constant Constant_Reference_Type :=
345 (Element => Position.Node.Element'Access,
346 Control => (Controlled with Position.Container))
352 end Constant_Reference;
354 function Constant_Reference
355 (Container : aliased Map;
356 Key : Key_Type) return Constant_Reference_Type
358 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
362 raise Constraint_Error with "key not in map";
366 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
367 B : Natural renames T.Busy;
368 L : Natural renames T.Lock;
370 return R : constant Constant_Reference_Type :=
371 (Element => Node.Element'Access,
372 Control => (Controlled with Container'Unrestricted_Access))
378 end Constant_Reference;
384 function Contains (Container : Map; Key : Key_Type) return Boolean is
386 return Find (Container, Key) /= No_Element;
393 function Copy (Source : Map) return Map is
395 return Target : Map do
396 Target.Assign (Source);
404 function Copy_Node (Source : Node_Access) return Node_Access is
405 Target : constant Node_Access :=
406 new Node_Type'(Color
=> Source
.Color
,
408 Element
=> Source
.Element
,
420 procedure Delete
(Container
: in out Map
; Position
: in out Cursor
) is
421 Tree
: Tree_Type
renames Container
.Tree
;
424 if Position
.Node
= null then
425 raise Constraint_Error
with
426 "Position cursor of Delete equals No_Element";
429 if Position
.Container
/= Container
'Unrestricted_Access then
430 raise Program_Error
with
431 "Position cursor of Delete designates wrong map";
434 pragma Assert
(Vet
(Tree
, Position
.Node
),
435 "Position cursor of Delete is bad");
437 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Position
.Node
);
438 Free
(Position
.Node
);
440 Position
.Container
:= null;
443 procedure Delete
(Container
: in out Map
; Key
: Key_Type
) is
444 X
: Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
448 raise Constraint_Error
with "key not in map";
451 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
459 procedure Delete_First
(Container
: in out Map
) is
460 X
: Node_Access
:= Container
.Tree
.First
;
464 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
473 procedure Delete_Last
(Container
: in out Map
) is
474 X
: Node_Access
:= Container
.Tree
.Last
;
478 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
487 function Element
(Position
: Cursor
) return Element_Type
is
489 if Position
.Node
= null then
490 raise Constraint_Error
with
491 "Position cursor of function Element equals No_Element";
494 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
495 "Position cursor of function Element is bad");
497 return Position
.Node
.Element
;
500 function Element
(Container
: Map
; Key
: Key_Type
) return Element_Type
is
501 Node
: constant Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
505 raise Constraint_Error
with "key not in map";
511 ---------------------
512 -- Equivalent_Keys --
513 ---------------------
515 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
530 procedure Exclude
(Container
: in out Map
; Key
: Key_Type
) is
531 X
: Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
535 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
544 procedure Finalize
(Object
: in out Iterator
) is
546 if Object
.Container
/= null then
548 B
: Natural renames Object
.Container
.all.Tree
.Busy
;
555 procedure Finalize
(Control
: in out Reference_Control_Type
) is
557 if Control
.Container
/= null then
559 T
: Tree_Type
renames Control
.Container
.all.Tree
;
560 B
: Natural renames T
.Busy
;
561 L
: Natural renames T
.Lock
;
567 Control
.Container
:= null;
575 function Find
(Container
: Map
; Key
: Key_Type
) return Cursor
is
576 Node
: constant Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
578 return (if Node
= null then No_Element
579 else Cursor
'(Container'Unrestricted_Access, Node));
586 function First (Container : Map) return Cursor is
587 T : Tree_Type renames Container.Tree;
589 if T.First = null then
592 return Cursor'(Container
'Unrestricted_Access, T
.First
);
596 function First
(Object
: Iterator
) return Cursor
is
598 -- The value of the iterator object's Node component influences the
599 -- behavior of the First (and Last) selector function.
601 -- When the Node component is null, this means the iterator object was
602 -- constructed without a start expression, in which case the (forward)
603 -- iteration starts from the (logical) beginning of the entire sequence
604 -- of items (corresponding to Container.First, for a forward iterator).
606 -- Otherwise, this is iteration over a partial sequence of items. When
607 -- the Node component is non-null, the iterator object was constructed
608 -- with a start expression, that specifies the position from which the
609 -- (forward) partial iteration begins.
611 if Object
.Node
= null then
612 return Object
.Container
.First
;
614 return Cursor
'(Object.Container, Object.Node);
622 function First_Element (Container : Map) return Element_Type is
623 T : Tree_Type renames Container.Tree;
625 if T.First = null then
626 raise Constraint_Error with "map is empty";
628 return T.First.Element;
636 function First_Key (Container : Map) return Key_Type is
637 T : Tree_Type renames Container.Tree;
639 if T.First = null then
640 raise Constraint_Error with "map is empty";
650 function Floor (Container : Map; Key : Key_Type) return Cursor is
651 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
656 return Cursor'(Container
'Unrestricted_Access, Node
);
664 procedure Free
(X
: in out Node_Access
) is
665 procedure Deallocate
is
666 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
680 ------------------------
681 -- Get_Element_Access --
682 ------------------------
684 function Get_Element_Access
685 (Position
: Cursor
) return not null Element_Access
is
687 return Position
.Node
.Element
'Access;
688 end Get_Element_Access
;
694 function Has_Element
(Position
: Cursor
) return Boolean is
696 return Position
/= No_Element
;
704 (Container
: in out Map
;
706 New_Item
: Element_Type
)
712 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
715 if Container
.Tree
.Lock
> 0 then
716 raise Program_Error
with
717 "attempt to tamper with elements (map is locked)";
720 Position
.Node
.Key
:= Key
;
721 Position
.Node
.Element
:= New_Item
;
730 (Container
: in out Map
;
732 New_Item
: Element_Type
;
733 Position
: out Cursor
;
734 Inserted
: out Boolean)
736 function New_Node
return Node_Access
;
737 pragma Inline
(New_Node
);
739 procedure Insert_Post
is
740 new Key_Ops
.Generic_Insert_Post
(New_Node
);
742 procedure Insert_Sans_Hint
is
743 new Key_Ops
.Generic_Conditional_Insert
(Insert_Post
);
749 function New_Node
return Node_Access
is
751 return new Node_Type
'(Key => Key,
753 Color => Red_Black_Trees.Red,
759 -- Start of processing for Insert
768 Position.Container := Container'Unrestricted_Access;
772 (Container : in out Map;
774 New_Item : Element_Type)
777 pragma Unreferenced (Position);
782 Insert (Container, Key, New_Item, Position, Inserted);
785 raise Constraint_Error with "key already in map";
790 (Container : in out Map;
792 Position : out Cursor;
793 Inserted : out Boolean)
795 function New_Node return Node_Access;
796 pragma Inline (New_Node);
798 procedure Insert_Post is
799 new Key_Ops.Generic_Insert_Post (New_Node);
801 procedure Insert_Sans_Hint is
802 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
808 function New_Node return Node_Access is
810 return new Node_Type'(Key
=> Key
,
812 Color
=> Red_Black_Trees
.Red
,
818 -- Start of processing for Insert
827 Position
.Container
:= Container
'Unrestricted_Access;
834 function Is_Empty
(Container
: Map
) return Boolean is
836 return Container
.Tree
.Length
= 0;
839 ------------------------
840 -- Is_Equal_Node_Node --
841 ------------------------
843 function Is_Equal_Node_Node
844 (L
, R
: Node_Access
) return Boolean
847 if L
.Key
< R
.Key
then
849 elsif R
.Key
< L
.Key
then
852 return L
.Element
= R
.Element
;
854 end Is_Equal_Node_Node
;
856 -------------------------
857 -- Is_Greater_Key_Node --
858 -------------------------
860 function Is_Greater_Key_Node
862 Right
: Node_Access
) return Boolean
865 -- Left > Right same as Right < Left
867 return Right
.Key
< Left
;
868 end Is_Greater_Key_Node
;
870 ----------------------
871 -- Is_Less_Key_Node --
872 ----------------------
874 function Is_Less_Key_Node
876 Right
: Node_Access
) return Boolean
879 return Left
< Right
.Key
;
880 end Is_Less_Key_Node
;
888 Process
: not null access procedure (Position
: Cursor
))
890 procedure Process_Node
(Node
: Node_Access
);
891 pragma Inline
(Process_Node
);
893 procedure Local_Iterate
is
894 new Tree_Operations
.Generic_Iteration
(Process_Node
);
900 procedure Process_Node
(Node
: Node_Access
) is
902 Process
(Cursor
'(Container'Unrestricted_Access, Node));
905 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
907 -- Start of processing for Iterate
913 Local_Iterate (Container.Tree);
924 (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
926 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
929 -- The value of the Node component influences the behavior of the First
930 -- and Last selector functions of the iterator object. When the Node
931 -- component is null (as is the case here), this means the iterator
932 -- object was constructed without a start expression. This is a
933 -- complete iterator, meaning that the iteration starts from the
934 -- (logical) beginning of the sequence of items.
936 -- Note: For a forward iterator, Container.First is the beginning, and
937 -- for a reverse iterator, Container.Last is the beginning.
939 return It : constant Iterator :=
940 (Limited_Controlled with
941 Container => Container'Unrestricted_Access,
948 function Iterate (Container : Map; Start : Cursor)
949 return Map_Iterator_Interfaces.Reversible_Iterator'Class
951 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
954 -- It was formerly the case that when Start = No_Element, the partial
955 -- iterator was defined to behave the same as for a complete iterator,
956 -- and iterate over the entire sequence of items. However, those
957 -- semantics were unintuitive and arguably error-prone (it is too easy
958 -- to accidentally create an endless loop), and so they were changed,
959 -- per the ARG meeting in Denver on 2011/11. However, there was no
960 -- consensus about what positive meaning this corner case should have,
961 -- and so it was decided to simply raise an exception. This does imply,
962 -- however, that it is not possible to use a partial iterator to specify
963 -- an empty sequence of items.
965 if Start = No_Element then
966 raise Constraint_Error with
967 "Start position for iterator equals No_Element";
970 if Start.Container /= Container'Unrestricted_Access then
971 raise Program_Error with
972 "Start cursor of Iterate designates wrong map";
975 pragma Assert (Vet (Container.Tree, Start.Node),
976 "Start cursor of Iterate is bad");
978 -- The value of the Node component influences the behavior of the First
979 -- and Last selector functions of the iterator object. When the Node
980 -- component is non-null (as is the case here), it means that this
981 -- is a partial iteration, over a subset of the complete sequence of
982 -- items. The iterator object was constructed with a start expression,
983 -- indicating the position from which the iteration begins. Note that
984 -- the start position has the same value irrespective of whether this
985 -- is a forward or reverse iteration.
987 return It : constant Iterator :=
988 (Limited_Controlled with
989 Container => Container'Unrestricted_Access,
1000 function Key (Position : Cursor) return Key_Type is
1002 if Position.Node = null then
1003 raise Constraint_Error with
1004 "Position cursor of function Key equals No_Element";
1007 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1008 "Position cursor of function Key is bad");
1010 return Position.Node.Key;
1017 function Last (Container : Map) return Cursor is
1018 T : Tree_Type renames Container.Tree;
1020 if T.Last = null then
1023 return Cursor'(Container
'Unrestricted_Access, T
.Last
);
1027 function Last
(Object
: Iterator
) return Cursor
is
1029 -- The value of the iterator object's Node component influences the
1030 -- behavior of the Last (and First) selector function.
1032 -- When the Node component is null, this means the iterator object was
1033 -- constructed without a start expression, in which case the (reverse)
1034 -- iteration starts from the (logical) beginning of the entire sequence
1035 -- (corresponding to Container.Last, for a reverse iterator).
1037 -- Otherwise, this is iteration over a partial sequence of items. When
1038 -- the Node component is non-null, the iterator object was constructed
1039 -- with a start expression, that specifies the position from which the
1040 -- (reverse) partial iteration begins.
1042 if Object
.Node
= null then
1043 return Object
.Container
.Last
;
1045 return Cursor
'(Object.Container, Object.Node);
1053 function Last_Element (Container : Map) return Element_Type is
1054 T : Tree_Type renames Container.Tree;
1056 if T.Last = null then
1057 raise Constraint_Error with "map is empty";
1059 return T.Last.Element;
1067 function Last_Key (Container : Map) return Key_Type is
1068 T : Tree_Type renames Container.Tree;
1070 if T.Last = null then
1071 raise Constraint_Error with "map is empty";
1081 function Left (Node : Node_Access) return Node_Access is
1090 function Length (Container : Map) return Count_Type is
1092 return Container.Tree.Length;
1100 new Tree_Operations.Generic_Move (Clear);
1102 procedure Move (Target : in out Map; Source : in out Map) is
1104 Move (Target => Target.Tree, Source => Source.Tree);
1111 procedure Next (Position : in out Cursor) is
1113 Position := Next (Position);
1116 function Next (Position : Cursor) return Cursor is
1118 if Position = No_Element then
1122 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1123 "Position cursor of Next is bad");
1126 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
1133 return Cursor'(Position
.Container
, Node
);
1139 Position
: Cursor
) return Cursor
1142 if Position
.Container
= null then
1146 if Position
.Container
/= Object
.Container
then
1147 raise Program_Error
with
1148 "Position cursor of Next designates wrong map";
1151 return Next
(Position
);
1158 function Parent
(Node
: Node_Access
) return Node_Access
is
1167 procedure Previous
(Position
: in out Cursor
) is
1169 Position
:= Previous
(Position
);
1172 function Previous
(Position
: Cursor
) return Cursor
is
1174 if Position
= No_Element
then
1178 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1179 "Position cursor of Previous is bad");
1182 Node
: constant Node_Access
:=
1183 Tree_Operations
.Previous
(Position
.Node
);
1190 return Cursor
'(Position.Container, Node);
1196 Position : Cursor) return Cursor
1199 if Position.Container = null then
1203 if Position.Container /= Object.Container then
1204 raise Program_Error with
1205 "Position cursor of Previous designates wrong map";
1208 return Previous (Position);
1211 ----------------------
1212 -- Pseudo_Reference --
1213 ----------------------
1215 function Pseudo_Reference
1216 (Container : aliased Map'Class) return Reference_Control_Type
1218 C : constant Map_Access := Container'Unrestricted_Access;
1219 B : Natural renames C.Tree.Busy;
1220 L : Natural renames C.Tree.Lock;
1222 return R : constant Reference_Control_Type :=
1228 end Pseudo_Reference;
1234 procedure Query_Element
1236 Process : not null access procedure (Key : Key_Type;
1237 Element : Element_Type))
1240 if Position.Node = null then
1241 raise Constraint_Error with
1242 "Position cursor of Query_Element equals No_Element";
1245 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1246 "Position cursor of Query_Element is bad");
1249 T : Tree_Type renames Position.Container.Tree;
1251 B : Natural renames T.Busy;
1252 L : Natural renames T.Lock;
1259 K : Key_Type renames Position.Node.Key;
1260 E : Element_Type renames Position.Node.Element;
1281 (Stream : not null access Root_Stream_Type'Class;
1282 Container : out Map)
1285 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1286 pragma Inline (Read_Node);
1289 new Tree_Operations.Generic_Read (Clear, Read_Node);
1296 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1298 Node : Node_Access := new Node_Type;
1300 Key_Type'Read (Stream, Node.Key);
1301 Element_Type'Read (Stream, Node.Element);
1309 -- Start of processing for Read
1312 Read (Stream, Container.Tree);
1316 (Stream : not null access Root_Stream_Type'Class;
1320 raise Program_Error with "attempt to stream map cursor";
1324 (Stream : not null access Root_Stream_Type'Class;
1325 Item : out Reference_Type)
1328 raise Program_Error with "attempt to stream reference";
1332 (Stream : not null access Root_Stream_Type'Class;
1333 Item : out Constant_Reference_Type)
1336 raise Program_Error with "attempt to stream reference";
1344 (Container : aliased in out Map;
1345 Position : Cursor) return Reference_Type
1348 if Position.Container = null then
1349 raise Constraint_Error with
1350 "Position cursor has no element";
1353 if Position.Container /= Container'Unrestricted_Access then
1354 raise Program_Error with
1355 "Position cursor designates wrong map";
1358 pragma Assert (Vet (Container.Tree, Position.Node),
1359 "Position cursor in function Reference is bad");
1362 T : Tree_Type renames Position.Container.all.Tree;
1363 B : Natural renames T.Busy;
1364 L : Natural renames T.Lock;
1366 return R : constant Reference_Type :=
1367 (Element => Position.Node.Element'Access,
1368 Control => (Controlled with Position.Container))
1377 (Container : aliased in out Map;
1378 Key : Key_Type) return Reference_Type
1380 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1384 raise Constraint_Error with "key not in map";
1388 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1389 B : Natural renames T.Busy;
1390 L : Natural renames T.Lock;
1392 return R : constant Reference_Type :=
1393 (Element => Node.Element'Access,
1394 Control => (Controlled with Container'Unrestricted_Access))
1407 (Container : in out Map;
1409 New_Item : Element_Type)
1411 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1415 raise Constraint_Error with "key not in map";
1418 if Container.Tree.Lock > 0 then
1419 raise Program_Error with
1420 "attempt to tamper with elements (map is locked)";
1424 Node.Element := New_Item;
1427 ---------------------
1428 -- Replace_Element --
1429 ---------------------
1431 procedure Replace_Element
1432 (Container : in out Map;
1434 New_Item : Element_Type)
1437 if Position.Node = null then
1438 raise Constraint_Error with
1439 "Position cursor of Replace_Element equals No_Element";
1442 if Position.Container /= Container'Unrestricted_Access then
1443 raise Program_Error with
1444 "Position cursor of Replace_Element designates wrong map";
1447 if Container.Tree.Lock > 0 then
1448 raise Program_Error with
1449 "attempt to tamper with elements (map is locked)";
1452 pragma Assert (Vet (Container.Tree, Position.Node),
1453 "Position cursor of Replace_Element is bad");
1455 Position.Node.Element := New_Item;
1456 end Replace_Element;
1458 ---------------------
1459 -- Reverse_Iterate --
1460 ---------------------
1462 procedure Reverse_Iterate
1464 Process : not null access procedure (Position : Cursor))
1466 procedure Process_Node (Node : Node_Access);
1467 pragma Inline (Process_Node);
1469 procedure Local_Reverse_Iterate is
1470 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1476 procedure Process_Node (Node : Node_Access) is
1478 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1481 B
: Natural renames Container
.Tree
'Unrestricted_Access.all.Busy
;
1483 -- Start of processing for Reverse_Iterate
1489 Local_Reverse_Iterate
(Container
.Tree
);
1497 end Reverse_Iterate
;
1503 function Right
(Node
: Node_Access
) return Node_Access
is
1513 (Node
: Node_Access
;
1517 Node
.Color
:= Color
;
1524 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
) is
1533 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
) is
1535 Node
.Parent
:= Parent
;
1542 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
) is
1544 Node
.Right
:= Right
;
1547 --------------------
1548 -- Update_Element --
1549 --------------------
1551 procedure Update_Element
1552 (Container
: in out Map
;
1554 Process
: not null access procedure (Key
: Key_Type
;
1555 Element
: in out Element_Type
))
1558 if Position
.Node
= null then
1559 raise Constraint_Error
with
1560 "Position cursor of Update_Element equals No_Element";
1563 if Position
.Container
/= Container
'Unrestricted_Access then
1564 raise Program_Error
with
1565 "Position cursor of Update_Element designates wrong map";
1568 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
1569 "Position cursor of Update_Element is bad");
1572 T
: Tree_Type
renames Container
.Tree
;
1574 B
: Natural renames T
.Busy
;
1575 L
: Natural renames T
.Lock
;
1582 K
: Key_Type
renames Position
.Node
.Key
;
1583 E
: Element_Type
renames Position
.Node
.Element
;
1605 (Stream
: not null access Root_Stream_Type
'Class;
1608 procedure Write_Node
1609 (Stream
: not null access Root_Stream_Type
'Class;
1610 Node
: Node_Access
);
1611 pragma Inline
(Write_Node
);
1614 new Tree_Operations
.Generic_Write
(Write_Node
);
1620 procedure Write_Node
1621 (Stream
: not null access Root_Stream_Type
'Class;
1625 Key_Type
'Write (Stream
, Node
.Key
);
1626 Element_Type
'Write (Stream
, Node
.Element
);
1629 -- Start of processing for Write
1632 Write
(Stream
, Container
.Tree
);
1636 (Stream
: not null access Root_Stream_Type
'Class;
1640 raise Program_Error
with "attempt to stream map cursor";
1644 (Stream
: not null access Root_Stream_Type
'Class;
1645 Item
: Reference_Type
)
1648 raise Program_Error
with "attempt to stream reference";
1652 (Stream
: not null access Root_Stream_Type
'Class;
1653 Item
: Constant_Reference_Type
)
1656 raise Program_Error
with "attempt to stream reference";
1659 end Ada
.Containers
.Ordered_Maps
;