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-2012, 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 type Iterator
is new Limited_Controlled
and
43 Map_Iterator_Interfaces
.Reversible_Iterator
with
45 Container
: Map_Access
;
49 overriding
procedure Finalize
(Object
: in out Iterator
);
51 overriding
function First
(Object
: Iterator
) return Cursor
;
52 overriding
function Last
(Object
: Iterator
) return Cursor
;
54 overriding
function Next
56 Position
: Cursor
) return Cursor
;
58 overriding
function Previous
60 Position
: Cursor
) return Cursor
;
62 -----------------------------
63 -- Node Access Subprograms --
64 -----------------------------
66 -- These subprograms provide a functional interface to access fields
67 -- of a node, and a procedural interface for modifying these values.
69 function Color
(Node
: Node_Access
) return Color_Type
;
70 pragma Inline
(Color
);
72 function Left
(Node
: Node_Access
) return Node_Access
;
75 function Parent
(Node
: Node_Access
) return Node_Access
;
76 pragma Inline
(Parent
);
78 function Right
(Node
: Node_Access
) return Node_Access
;
79 pragma Inline
(Right
);
81 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
82 pragma Inline
(Set_Parent
);
84 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
85 pragma Inline
(Set_Left
);
87 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
88 pragma Inline
(Set_Right
);
90 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
91 pragma Inline
(Set_Color
);
93 -----------------------
94 -- Local Subprograms --
95 -----------------------
97 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
98 pragma Inline
(Copy_Node
);
100 procedure Free
(X
: in out Node_Access
);
102 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean;
103 pragma Inline
(Is_Equal_Node_Node
);
105 function Is_Greater_Key_Node
107 Right
: Node_Access
) return Boolean;
108 pragma Inline
(Is_Greater_Key_Node
);
110 function Is_Less_Key_Node
112 Right
: Node_Access
) return Boolean;
113 pragma Inline
(Is_Less_Key_Node
);
115 --------------------------
116 -- Local Instantiations --
117 --------------------------
119 package Tree_Operations
is
120 new Red_Black_Trees
.Generic_Operations
(Tree_Types
);
122 procedure Delete_Tree
is
123 new Tree_Operations
.Generic_Delete_Tree
(Free
);
125 function Copy_Tree
is
126 new Tree_Operations
.Generic_Copy_Tree
(Copy_Node
, Delete_Tree
);
131 new Red_Black_Trees
.Generic_Keys
132 (Tree_Operations
=> Tree_Operations
,
133 Key_Type
=> Key_Type
,
134 Is_Less_Key_Node
=> Is_Less_Key_Node
,
135 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
138 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
144 function "<" (Left
, Right
: Cursor
) return Boolean is
146 if Left
.Node
= null then
147 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
150 if Right
.Node
= null then
151 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
154 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
155 "Left cursor of ""<"" is bad");
157 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
158 "Right cursor of ""<"" is bad");
160 return Left
.Node
.Key
< Right
.Node
.Key
;
163 function "<" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
165 if Left
.Node
= null then
166 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
169 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
170 "Left cursor of ""<"" is bad");
172 return Left
.Node
.Key
< Right
;
175 function "<" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
177 if Right
.Node
= null then
178 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
181 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
182 "Right cursor of ""<"" is bad");
184 return Left
< Right
.Node
.Key
;
191 function "=" (Left
, Right
: Map
) return Boolean is
193 return Is_Equal
(Left
.Tree
, Right
.Tree
);
200 function ">" (Left
, Right
: Cursor
) return Boolean is
202 if Left
.Node
= null then
203 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
206 if Right
.Node
= null then
207 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
210 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
211 "Left cursor of "">"" is bad");
213 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
214 "Right cursor of "">"" is bad");
216 return Right
.Node
.Key
< Left
.Node
.Key
;
219 function ">" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
221 if Left
.Node
= null then
222 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
225 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
226 "Left cursor of "">"" is bad");
228 return Right
< Left
.Node
.Key
;
231 function ">" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
233 if Right
.Node
= null then
234 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
237 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
238 "Right cursor of "">"" is bad");
240 return Right
.Node
.Key
< Left
;
248 new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
250 procedure Adjust
(Container
: in out Map
) is
252 Adjust
(Container
.Tree
);
255 procedure Adjust
(Control
: in out Reference_Control_Type
) is
257 if Control
.Container
/= null then
259 T
: Tree_Type
renames Control
.Container
.all.Tree
;
260 B
: Natural renames T
.Busy
;
261 L
: Natural renames T
.Lock
;
273 procedure Assign
(Target
: in out Map
; Source
: Map
) is
274 procedure Insert_Item
(Node
: Node_Access
);
275 pragma Inline
(Insert_Item
);
277 procedure Insert_Items
is
278 new Tree_Operations
.Generic_Iteration
(Insert_Item
);
284 procedure Insert_Item
(Node
: Node_Access
) is
286 Target
.Insert
(Key
=> Node
.Key
, New_Item
=> Node
.Element
);
289 -- Start of processing for Assign
292 if Target
'Address = Source
'Address then
297 Insert_Items
(Target
.Tree
);
304 function Ceiling
(Container
: Map
; Key
: Key_Type
) return Cursor
is
305 Node
: constant Node_Access
:= Key_Ops
.Ceiling
(Container
.Tree
, Key
);
312 return Cursor
'(Container'Unrestricted_Access, Node);
319 procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree);
321 procedure Clear (Container : in out Map) is
323 Clear (Container.Tree);
330 function Color (Node : Node_Access) return Color_Type is
335 ------------------------
336 -- Constant_Reference --
337 ------------------------
339 function Constant_Reference
340 (Container : aliased Map;
341 Position : Cursor) return Constant_Reference_Type
344 if Position.Container = null then
345 raise Constraint_Error with
346 "Position cursor has no element";
349 if Position.Container /= Container'Unrestricted_Access then
350 raise Program_Error with
351 "Position cursor designates wrong map";
354 pragma Assert (Vet (Container.Tree, Position.Node),
355 "Position cursor in Constant_Reference is bad");
358 T : Tree_Type renames Position.Container.all.Tree;
359 B : Natural renames T.Busy;
360 L : Natural renames T.Lock;
362 return R : constant Constant_Reference_Type :=
363 (Element => Position.Node.Element'Access,
364 Control => (Controlled with Position.Container))
370 end Constant_Reference;
372 function Constant_Reference
373 (Container : aliased Map;
374 Key : Key_Type) return Constant_Reference_Type
376 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
380 raise Constraint_Error with "key not in map";
384 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
385 B : Natural renames T.Busy;
386 L : Natural renames T.Lock;
388 return R : constant Constant_Reference_Type :=
389 (Element => Node.Element'Access,
390 Control => (Controlled with Container'Unrestricted_Access))
396 end Constant_Reference;
402 function Contains (Container : Map; Key : Key_Type) return Boolean is
404 return Find (Container, Key) /= No_Element;
411 function Copy (Source : Map) return Map is
413 return Target : Map do
414 Target.Assign (Source);
422 function Copy_Node (Source : Node_Access) return Node_Access is
423 Target : constant Node_Access :=
424 new Node_Type'(Color
=> Source
.Color
,
426 Element
=> Source
.Element
,
438 procedure Delete
(Container
: in out Map
; Position
: in out Cursor
) is
439 Tree
: Tree_Type
renames Container
.Tree
;
442 if Position
.Node
= null then
443 raise Constraint_Error
with
444 "Position cursor of Delete equals No_Element";
447 if Position
.Container
/= Container
'Unrestricted_Access then
448 raise Program_Error
with
449 "Position cursor of Delete designates wrong map";
452 pragma Assert
(Vet
(Tree
, Position
.Node
),
453 "Position cursor of Delete is bad");
455 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Position
.Node
);
456 Free
(Position
.Node
);
458 Position
.Container
:= null;
461 procedure Delete
(Container
: in out Map
; Key
: Key_Type
) is
462 X
: Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
466 raise Constraint_Error
with "key not in map";
469 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
477 procedure Delete_First
(Container
: in out Map
) is
478 X
: Node_Access
:= Container
.Tree
.First
;
482 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
491 procedure Delete_Last
(Container
: in out Map
) is
492 X
: Node_Access
:= Container
.Tree
.Last
;
496 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
505 function Element
(Position
: Cursor
) return Element_Type
is
507 if Position
.Node
= null then
508 raise Constraint_Error
with
509 "Position cursor of function Element equals No_Element";
512 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
513 "Position cursor of function Element is bad");
515 return Position
.Node
.Element
;
518 function Element
(Container
: Map
; Key
: Key_Type
) return Element_Type
is
519 Node
: constant Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
523 raise Constraint_Error
with "key not in map";
529 ---------------------
530 -- Equivalent_Keys --
531 ---------------------
533 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
548 procedure Exclude
(Container
: in out Map
; Key
: Key_Type
) is
549 X
: Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
553 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
562 procedure Finalize
(Object
: in out Iterator
) is
564 if Object
.Container
/= null then
566 B
: Natural renames Object
.Container
.all.Tree
.Busy
;
573 procedure Finalize
(Control
: in out Reference_Control_Type
) is
575 if Control
.Container
/= null then
577 T
: Tree_Type
renames Control
.Container
.all.Tree
;
578 B
: Natural renames T
.Busy
;
579 L
: Natural renames T
.Lock
;
585 Control
.Container
:= null;
593 function Find
(Container
: Map
; Key
: Key_Type
) return Cursor
is
594 Node
: constant Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
596 return (if Node
= null then No_Element
597 else Cursor
'(Container'Unrestricted_Access, Node));
604 function First (Container : Map) return Cursor is
605 T : Tree_Type renames Container.Tree;
607 if T.First = null then
610 return Cursor'(Container
'Unrestricted_Access, T
.First
);
614 function First
(Object
: Iterator
) return Cursor
is
616 -- The value of the iterator object's Node component influences the
617 -- behavior of the First (and Last) selector function.
619 -- When the Node component is null, this means the iterator object was
620 -- constructed without a start expression, in which case the (forward)
621 -- iteration starts from the (logical) beginning of the entire sequence
622 -- of items (corresponding to Container.First, for a forward iterator).
624 -- Otherwise, this is iteration over a partial sequence of items. When
625 -- the Node component is non-null, the iterator object was constructed
626 -- with a start expression, that specifies the position from which the
627 -- (forward) partial iteration begins.
629 if Object
.Node
= null then
630 return Object
.Container
.First
;
632 return Cursor
'(Object.Container, Object.Node);
640 function First_Element (Container : Map) return Element_Type is
641 T : Tree_Type renames Container.Tree;
643 if T.First = null then
644 raise Constraint_Error with "map is empty";
646 return T.First.Element;
654 function First_Key (Container : Map) return Key_Type is
655 T : Tree_Type renames Container.Tree;
657 if T.First = null then
658 raise Constraint_Error with "map is empty";
668 function Floor (Container : Map; Key : Key_Type) return Cursor is
669 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
674 return Cursor'(Container
'Unrestricted_Access, Node
);
682 procedure Free
(X
: in out Node_Access
) is
683 procedure Deallocate
is
684 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
702 function Has_Element
(Position
: Cursor
) return Boolean is
704 return Position
/= No_Element
;
712 (Container
: in out Map
;
714 New_Item
: Element_Type
)
720 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
723 if Container
.Tree
.Lock
> 0 then
724 raise Program_Error
with
725 "attempt to tamper with elements (map is locked)";
728 Position
.Node
.Key
:= Key
;
729 Position
.Node
.Element
:= New_Item
;
738 (Container
: in out Map
;
740 New_Item
: Element_Type
;
741 Position
: out Cursor
;
742 Inserted
: out Boolean)
744 function New_Node
return Node_Access
;
745 pragma Inline
(New_Node
);
747 procedure Insert_Post
is
748 new Key_Ops
.Generic_Insert_Post
(New_Node
);
750 procedure Insert_Sans_Hint
is
751 new Key_Ops
.Generic_Conditional_Insert
(Insert_Post
);
757 function New_Node
return Node_Access
is
759 return new Node_Type
'(Key => Key,
761 Color => Red_Black_Trees.Red,
767 -- Start of processing for Insert
776 Position.Container := Container'Unrestricted_Access;
780 (Container : in out Map;
782 New_Item : Element_Type)
785 pragma Unreferenced (Position);
790 Insert (Container, Key, New_Item, Position, Inserted);
793 raise Constraint_Error with "key already in map";
798 (Container : in out Map;
800 Position : out Cursor;
801 Inserted : out Boolean)
803 function New_Node return Node_Access;
804 pragma Inline (New_Node);
806 procedure Insert_Post is
807 new Key_Ops.Generic_Insert_Post (New_Node);
809 procedure Insert_Sans_Hint is
810 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
816 function New_Node return Node_Access is
818 return new Node_Type'(Key
=> Key
,
820 Color
=> Red_Black_Trees
.Red
,
826 -- Start of processing for Insert
835 Position
.Container
:= Container
'Unrestricted_Access;
842 function Is_Empty
(Container
: Map
) return Boolean is
844 return Container
.Tree
.Length
= 0;
847 ------------------------
848 -- Is_Equal_Node_Node --
849 ------------------------
851 function Is_Equal_Node_Node
852 (L
, R
: Node_Access
) return Boolean
855 if L
.Key
< R
.Key
then
857 elsif R
.Key
< L
.Key
then
860 return L
.Element
= R
.Element
;
862 end Is_Equal_Node_Node
;
864 -------------------------
865 -- Is_Greater_Key_Node --
866 -------------------------
868 function Is_Greater_Key_Node
870 Right
: Node_Access
) return Boolean
873 -- Left > Right same as Right < Left
875 return Right
.Key
< Left
;
876 end Is_Greater_Key_Node
;
878 ----------------------
879 -- Is_Less_Key_Node --
880 ----------------------
882 function Is_Less_Key_Node
884 Right
: Node_Access
) return Boolean
887 return Left
< Right
.Key
;
888 end Is_Less_Key_Node
;
896 Process
: not null access procedure (Position
: Cursor
))
898 procedure Process_Node
(Node
: Node_Access
);
899 pragma Inline
(Process_Node
);
901 procedure Local_Iterate
is
902 new Tree_Operations
.Generic_Iteration
(Process_Node
);
908 procedure Process_Node
(Node
: Node_Access
) is
910 Process
(Cursor
'(Container'Unrestricted_Access, Node));
913 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
915 -- Start of processing for Iterate
921 Local_Iterate (Container.Tree);
932 (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
934 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
937 -- The value of the Node component influences the behavior of the First
938 -- and Last selector functions of the iterator object. When the Node
939 -- component is null (as is the case here), this means the iterator
940 -- object was constructed without a start expression. This is a
941 -- complete iterator, meaning that the iteration starts from the
942 -- (logical) beginning of the sequence of items.
944 -- Note: For a forward iterator, Container.First is the beginning, and
945 -- for a reverse iterator, Container.Last is the beginning.
947 return It : constant Iterator :=
948 (Limited_Controlled with
949 Container => Container'Unrestricted_Access,
956 function Iterate (Container : Map; Start : Cursor)
957 return Map_Iterator_Interfaces.Reversible_Iterator'Class
959 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
962 -- It was formerly the case that when Start = No_Element, the partial
963 -- iterator was defined to behave the same as for a complete iterator,
964 -- and iterate over the entire sequence of items. However, those
965 -- semantics were unintuitive and arguably error-prone (it is too easy
966 -- to accidentally create an endless loop), and so they were changed,
967 -- per the ARG meeting in Denver on 2011/11. However, there was no
968 -- consensus about what positive meaning this corner case should have,
969 -- and so it was decided to simply raise an exception. This does imply,
970 -- however, that it is not possible to use a partial iterator to specify
971 -- an empty sequence of items.
973 if Start = No_Element then
974 raise Constraint_Error with
975 "Start position for iterator equals No_Element";
978 if Start.Container /= Container'Unrestricted_Access then
979 raise Program_Error with
980 "Start cursor of Iterate designates wrong map";
983 pragma Assert (Vet (Container.Tree, Start.Node),
984 "Start cursor of Iterate is bad");
986 -- The value of the Node component influences the behavior of the First
987 -- and Last selector functions of the iterator object. When the Node
988 -- component is non-null (as is the case here), it means that this
989 -- is a partial iteration, over a subset of the complete sequence of
990 -- items. The iterator object was constructed with a start expression,
991 -- indicating the position from which the iteration begins. Note that
992 -- the start position has the same value irrespective of whether this
993 -- is a forward or reverse iteration.
995 return It : constant Iterator :=
996 (Limited_Controlled with
997 Container => Container'Unrestricted_Access,
1008 function Key (Position : Cursor) return Key_Type is
1010 if Position.Node = null then
1011 raise Constraint_Error with
1012 "Position cursor of function Key equals No_Element";
1015 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1016 "Position cursor of function Key is bad");
1018 return Position.Node.Key;
1025 function Last (Container : Map) return Cursor is
1026 T : Tree_Type renames Container.Tree;
1028 if T.Last = null then
1031 return Cursor'(Container
'Unrestricted_Access, T
.Last
);
1035 function Last
(Object
: Iterator
) return Cursor
is
1037 -- The value of the iterator object's Node component influences the
1038 -- behavior of the Last (and First) selector function.
1040 -- When the Node component is null, this means the iterator object was
1041 -- constructed without a start expression, in which case the (reverse)
1042 -- iteration starts from the (logical) beginning of the entire sequence
1043 -- (corresponding to Container.Last, for a reverse iterator).
1045 -- Otherwise, this is iteration over a partial sequence of items. When
1046 -- the Node component is non-null, the iterator object was constructed
1047 -- with a start expression, that specifies the position from which the
1048 -- (reverse) partial iteration begins.
1050 if Object
.Node
= null then
1051 return Object
.Container
.Last
;
1053 return Cursor
'(Object.Container, Object.Node);
1061 function Last_Element (Container : Map) return Element_Type is
1062 T : Tree_Type renames Container.Tree;
1064 if T.Last = null then
1065 raise Constraint_Error with "map is empty";
1067 return T.Last.Element;
1075 function Last_Key (Container : Map) return Key_Type is
1076 T : Tree_Type renames Container.Tree;
1078 if T.Last = null then
1079 raise Constraint_Error with "map is empty";
1089 function Left (Node : Node_Access) return Node_Access is
1098 function Length (Container : Map) return Count_Type is
1100 return Container.Tree.Length;
1108 new Tree_Operations.Generic_Move (Clear);
1110 procedure Move (Target : in out Map; Source : in out Map) is
1112 Move (Target => Target.Tree, Source => Source.Tree);
1119 procedure Next (Position : in out Cursor) is
1121 Position := Next (Position);
1124 function Next (Position : Cursor) return Cursor is
1126 if Position = No_Element then
1130 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1131 "Position cursor of Next is bad");
1134 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
1141 return Cursor'(Position
.Container
, Node
);
1147 Position
: Cursor
) return Cursor
1150 if Position
.Container
= null then
1154 if Position
.Container
/= Object
.Container
then
1155 raise Program_Error
with
1156 "Position cursor of Next designates wrong map";
1159 return Next
(Position
);
1166 function Parent
(Node
: Node_Access
) return Node_Access
is
1175 procedure Previous
(Position
: in out Cursor
) is
1177 Position
:= Previous
(Position
);
1180 function Previous
(Position
: Cursor
) return Cursor
is
1182 if Position
= No_Element
then
1186 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1187 "Position cursor of Previous is bad");
1190 Node
: constant Node_Access
:=
1191 Tree_Operations
.Previous
(Position
.Node
);
1198 return Cursor
'(Position.Container, Node);
1204 Position : Cursor) return Cursor
1207 if Position.Container = null then
1211 if Position.Container /= Object.Container then
1212 raise Program_Error with
1213 "Position cursor of Previous designates wrong map";
1216 return Previous (Position);
1223 procedure Query_Element
1225 Process : not null access procedure (Key : Key_Type;
1226 Element : Element_Type))
1229 if Position.Node = null then
1230 raise Constraint_Error with
1231 "Position cursor of Query_Element equals No_Element";
1234 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1235 "Position cursor of Query_Element is bad");
1238 T : Tree_Type renames Position.Container.Tree;
1240 B : Natural renames T.Busy;
1241 L : Natural renames T.Lock;
1248 K : Key_Type renames Position.Node.Key;
1249 E : Element_Type renames Position.Node.Element;
1270 (Stream : not null access Root_Stream_Type'Class;
1271 Container : out Map)
1274 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1275 pragma Inline (Read_Node);
1278 new Tree_Operations.Generic_Read (Clear, Read_Node);
1285 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1287 Node : Node_Access := new Node_Type;
1289 Key_Type'Read (Stream, Node.Key);
1290 Element_Type'Read (Stream, Node.Element);
1298 -- Start of processing for Read
1301 Read (Stream, Container.Tree);
1305 (Stream : not null access Root_Stream_Type'Class;
1309 raise Program_Error with "attempt to stream map cursor";
1313 (Stream : not null access Root_Stream_Type'Class;
1314 Item : out Reference_Type)
1317 raise Program_Error with "attempt to stream reference";
1321 (Stream : not null access Root_Stream_Type'Class;
1322 Item : out Constant_Reference_Type)
1325 raise Program_Error with "attempt to stream reference";
1333 (Container : aliased in out Map;
1334 Position : Cursor) return Reference_Type
1337 if Position.Container = null then
1338 raise Constraint_Error with
1339 "Position cursor has no element";
1342 if Position.Container /= Container'Unrestricted_Access then
1343 raise Program_Error with
1344 "Position cursor designates wrong map";
1347 pragma Assert (Vet (Container.Tree, Position.Node),
1348 "Position cursor in function Reference is bad");
1351 T : Tree_Type renames Position.Container.all.Tree;
1352 B : Natural renames T.Busy;
1353 L : Natural renames T.Lock;
1355 return R : constant Reference_Type :=
1356 (Element => Position.Node.Element'Access,
1357 Control => (Controlled with Position.Container))
1366 (Container : aliased in out Map;
1367 Key : Key_Type) return Reference_Type
1369 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1373 raise Constraint_Error with "key not in map";
1377 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1378 B : Natural renames T.Busy;
1379 L : Natural renames T.Lock;
1381 return R : constant Reference_Type :=
1382 (Element => Node.Element'Access,
1383 Control => (Controlled with Container'Unrestricted_Access))
1396 (Container : in out Map;
1398 New_Item : Element_Type)
1400 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1404 raise Constraint_Error with "key not in map";
1407 if Container.Tree.Lock > 0 then
1408 raise Program_Error with
1409 "attempt to tamper with elements (map is locked)";
1413 Node.Element := New_Item;
1416 ---------------------
1417 -- Replace_Element --
1418 ---------------------
1420 procedure Replace_Element
1421 (Container : in out Map;
1423 New_Item : Element_Type)
1426 if Position.Node = null then
1427 raise Constraint_Error with
1428 "Position cursor of Replace_Element equals No_Element";
1431 if Position.Container /= Container'Unrestricted_Access then
1432 raise Program_Error with
1433 "Position cursor of Replace_Element designates wrong map";
1436 if Container.Tree.Lock > 0 then
1437 raise Program_Error with
1438 "attempt to tamper with elements (map is locked)";
1441 pragma Assert (Vet (Container.Tree, Position.Node),
1442 "Position cursor of Replace_Element is bad");
1444 Position.Node.Element := New_Item;
1445 end Replace_Element;
1447 ---------------------
1448 -- Reverse_Iterate --
1449 ---------------------
1451 procedure Reverse_Iterate
1453 Process : not null access procedure (Position : Cursor))
1455 procedure Process_Node (Node : Node_Access);
1456 pragma Inline (Process_Node);
1458 procedure Local_Reverse_Iterate is
1459 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1465 procedure Process_Node (Node : Node_Access) is
1467 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1470 B
: Natural renames Container
.Tree
'Unrestricted_Access.all.Busy
;
1472 -- Start of processing for Reverse_Iterate
1478 Local_Reverse_Iterate
(Container
.Tree
);
1486 end Reverse_Iterate
;
1492 function Right
(Node
: Node_Access
) return Node_Access
is
1502 (Node
: Node_Access
;
1506 Node
.Color
:= Color
;
1513 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
) is
1522 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
) is
1524 Node
.Parent
:= Parent
;
1531 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
) is
1533 Node
.Right
:= Right
;
1536 --------------------
1537 -- Update_Element --
1538 --------------------
1540 procedure Update_Element
1541 (Container
: in out Map
;
1543 Process
: not null access procedure (Key
: Key_Type
;
1544 Element
: in out Element_Type
))
1547 if Position
.Node
= null then
1548 raise Constraint_Error
with
1549 "Position cursor of Update_Element equals No_Element";
1552 if Position
.Container
/= Container
'Unrestricted_Access then
1553 raise Program_Error
with
1554 "Position cursor of Update_Element designates wrong map";
1557 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
1558 "Position cursor of Update_Element is bad");
1561 T
: Tree_Type
renames Container
.Tree
;
1563 B
: Natural renames T
.Busy
;
1564 L
: Natural renames T
.Lock
;
1571 K
: Key_Type
renames Position
.Node
.Key
;
1572 E
: Element_Type
renames Position
.Node
.Element
;
1594 (Stream
: not null access Root_Stream_Type
'Class;
1597 procedure Write_Node
1598 (Stream
: not null access Root_Stream_Type
'Class;
1599 Node
: Node_Access
);
1600 pragma Inline
(Write_Node
);
1603 new Tree_Operations
.Generic_Write
(Write_Node
);
1609 procedure Write_Node
1610 (Stream
: not null access Root_Stream_Type
'Class;
1614 Key_Type
'Write (Stream
, Node
.Key
);
1615 Element_Type
'Write (Stream
, Node
.Element
);
1618 -- Start of processing for Write
1621 Write
(Stream
, Container
.Tree
);
1625 (Stream
: not null access Root_Stream_Type
'Class;
1629 raise Program_Error
with "attempt to stream map cursor";
1633 (Stream
: not null access Root_Stream_Type
'Class;
1634 Item
: Reference_Type
)
1637 raise Program_Error
with "attempt to stream reference";
1641 (Stream
: not null access Root_Stream_Type
'Class;
1642 Item
: Constant_Reference_Type
)
1645 raise Program_Error
with "attempt to stream reference";
1648 end Ada
.Containers
.Ordered_Maps
;