1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ M A P S --
9 -- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Operations
;
32 (Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Operations
);
34 with Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Keys
;
36 (Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Keys
);
38 with Ada
.Finalization
; use Ada
.Finalization
;
40 with System
; use type System
.Address
;
42 package body Ada
.Containers
.Bounded_Ordered_Maps
is
44 type Iterator
is new Limited_Controlled
and
45 Map_Iterator_Interfaces
.Reversible_Iterator
with
47 Container
: Map_Access
;
51 overriding
procedure Finalize
(Object
: in out Iterator
);
53 overriding
function First
(Object
: Iterator
) return Cursor
;
54 overriding
function Last
(Object
: Iterator
) return Cursor
;
56 overriding
function Next
58 Position
: Cursor
) return Cursor
;
60 overriding
function Previous
62 Position
: Cursor
) return Cursor
;
64 -----------------------------
65 -- Node Access Subprograms --
66 -----------------------------
68 -- These subprograms provide a functional interface to access fields
69 -- of a node, and a procedural interface for modifying these values.
71 function Color
(Node
: Node_Type
) return Color_Type
;
72 pragma Inline
(Color
);
74 function Left
(Node
: Node_Type
) return Count_Type
;
77 function Parent
(Node
: Node_Type
) return Count_Type
;
78 pragma Inline
(Parent
);
80 function Right
(Node
: Node_Type
) return Count_Type
;
81 pragma Inline
(Right
);
83 procedure Set_Parent
(Node
: in out Node_Type
; Parent
: Count_Type
);
84 pragma Inline
(Set_Parent
);
86 procedure Set_Left
(Node
: in out Node_Type
; Left
: Count_Type
);
87 pragma Inline
(Set_Left
);
89 procedure Set_Right
(Node
: in out Node_Type
; Right
: Count_Type
);
90 pragma Inline
(Set_Right
);
92 procedure Set_Color
(Node
: in out Node_Type
; Color
: Color_Type
);
93 pragma Inline
(Set_Color
);
95 -----------------------
96 -- Local Subprograms --
97 -----------------------
99 function Is_Greater_Key_Node
101 Right
: Node_Type
) return Boolean;
102 pragma Inline
(Is_Greater_Key_Node
);
104 function Is_Less_Key_Node
106 Right
: Node_Type
) return Boolean;
107 pragma Inline
(Is_Less_Key_Node
);
109 --------------------------
110 -- Local Instantiations --
111 --------------------------
113 package Tree_Operations
is
114 new Red_Black_Trees
.Generic_Bounded_Operations
(Tree_Types
);
119 new Red_Black_Trees
.Generic_Bounded_Keys
120 (Tree_Operations
=> Tree_Operations
,
121 Key_Type
=> Key_Type
,
122 Is_Less_Key_Node
=> Is_Less_Key_Node
,
123 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
129 function "<" (Left
, Right
: Cursor
) return Boolean is
131 if Left
.Node
= 0 then
132 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
135 if Right
.Node
= 0 then
136 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
139 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
140 "Left cursor of ""<"" is bad");
142 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
143 "Right cursor of ""<"" is bad");
146 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
147 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
150 return LN
.Key
< RN
.Key
;
154 function "<" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
156 if Left
.Node
= 0 then
157 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
160 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
161 "Left cursor of ""<"" is bad");
164 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
167 return LN
.Key
< Right
;
171 function "<" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
173 if Right
.Node
= 0 then
174 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
177 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
178 "Right cursor of ""<"" is bad");
181 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
184 return Left
< RN
.Key
;
192 function "=" (Left
, Right
: Map
) return Boolean is
193 function Is_Equal_Node_Node
(L
, R
: Node_Type
) return Boolean;
194 pragma Inline
(Is_Equal_Node_Node
);
197 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
199 ------------------------
200 -- Is_Equal_Node_Node --
201 ------------------------
203 function Is_Equal_Node_Node
204 (L
, R
: Node_Type
) return Boolean is
206 if L
.Key
< R
.Key
then
209 elsif R
.Key
< L
.Key
then
213 return L
.Element
= R
.Element
;
215 end Is_Equal_Node_Node
;
217 -- Start of processing for "="
220 return Is_Equal
(Left
, Right
);
227 function ">" (Left
, Right
: Cursor
) return Boolean is
229 if Left
.Node
= 0 then
230 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
233 if Right
.Node
= 0 then
234 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
237 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
238 "Left cursor of "">"" is bad");
240 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
241 "Right cursor of "">"" is bad");
244 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
245 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
248 return RN
.Key
< LN
.Key
;
252 function ">" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
254 if Left
.Node
= 0 then
255 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
258 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
259 "Left cursor of "">"" is bad");
262 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
264 return Right
< LN
.Key
;
268 function ">" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
270 if Right
.Node
= 0 then
271 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
274 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
275 "Right cursor of "">"" is bad");
278 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
281 return RN
.Key
< Left
;
289 procedure Assign
(Target
: in out Map
; Source
: Map
) is
290 procedure Append_Element
(Source_Node
: Count_Type
);
292 procedure Append_Elements
is
293 new Tree_Operations
.Generic_Iteration
(Append_Element
);
299 procedure Append_Element
(Source_Node
: Count_Type
) is
300 SN
: Node_Type
renames Source
.Nodes
(Source_Node
);
302 procedure Set_Element
(Node
: in out Node_Type
);
303 pragma Inline
(Set_Element
);
305 function New_Node
return Count_Type
;
306 pragma Inline
(New_Node
);
308 procedure Insert_Post
is
309 new Key_Ops
.Generic_Insert_Post
(New_Node
);
311 procedure Unconditional_Insert_Sans_Hint
is
312 new Key_Ops
.Generic_Unconditional_Insert
(Insert_Post
);
314 procedure Unconditional_Insert_Avec_Hint
is
315 new Key_Ops
.Generic_Unconditional_Insert_With_Hint
317 Unconditional_Insert_Sans_Hint
);
319 procedure Allocate
is
320 new Tree_Operations
.Generic_Allocate
(Set_Element
);
326 function New_Node
return Count_Type
is
330 Allocate
(Target
, Result
);
338 procedure Set_Element
(Node
: in out Node_Type
) is
341 Node
.Element
:= SN
.Element
;
344 Target_Node
: Count_Type
;
346 -- Start of processing for Append_Element
349 Unconditional_Insert_Avec_Hint
353 Node
=> Target_Node
);
356 -- Start of processing for Assign
359 if Target
'Address = Source
'Address then
363 if Target
.Capacity
< Source
.Length
then
365 with "Target capacity is less than Source length";
368 Tree_Operations
.Clear_Tree
(Target
);
369 Append_Elements
(Source
);
376 function Ceiling
(Container
: Map
; Key
: Key_Type
) return Cursor
is
377 Node
: constant Count_Type
:= Key_Ops
.Ceiling
(Container
, Key
);
384 return Cursor
'(Container'Unrestricted_Access, Node);
391 procedure Clear (Container : in out Map) is
393 Tree_Operations.Clear_Tree (Container);
400 function Color (Node : Node_Type) return Color_Type is
405 ------------------------
406 -- Constant_Reference --
407 ------------------------
409 function Constant_Reference
410 (Container : aliased Map;
411 Position : Cursor) return Constant_Reference_Type
414 if Position.Container = null then
415 raise Constraint_Error with
416 "Position cursor has no element";
419 if Position.Container /= Container'Unrestricted_Access then
420 raise Program_Error with
421 "Position cursor designates wrong map";
424 pragma Assert (Vet (Container, Position.Node),
425 "Position cursor in Constant_Reference is bad");
428 N : Node_Type renames Container.Nodes (Position.Node);
430 return (Element => N.Element'Access);
432 end Constant_Reference;
434 function Constant_Reference
436 Key : Key_Type) return Constant_Reference_Type
438 Node : constant Count_Type := Key_Ops.Find (Container, Key);
442 raise Constraint_Error with "key not in map";
446 N : Node_Type renames Container.Nodes (Node);
448 return (Element => N.Element'Access);
450 end Constant_Reference;
456 function Contains (Container : Map; Key : Key_Type) return Boolean is
458 return Find (Container, Key) /= No_Element;
465 function Copy (Source : Map; Capacity : Count_Type := 0) return Map is
472 elsif Capacity >= Source.Length then
476 raise Capacity_Error with "Capacity value too small";
479 return Target : Map (Capacity => C) do
480 Assign (Target => Target, Source => Source);
488 procedure Delete (Container : in out Map; Position : in out Cursor) is
490 if Position.Node = 0 then
491 raise Constraint_Error with
492 "Position cursor of Delete equals No_Element";
495 if Position.Container /= Container'Unrestricted_Access then
496 raise Program_Error with
497 "Position cursor of Delete designates wrong map";
500 pragma Assert (Vet (Container, Position.Node),
501 "Position cursor of Delete is bad");
503 Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
504 Tree_Operations.Free (Container, Position.Node);
506 Position := No_Element;
509 procedure Delete (Container : in out Map; Key : Key_Type) is
510 X : constant Count_Type := Key_Ops.Find (Container, Key);
514 raise Constraint_Error with "key not in map";
517 Tree_Operations.Delete_Node_Sans_Free (Container, X);
518 Tree_Operations.Free (Container, X);
525 procedure Delete_First (Container : in out Map) is
526 X : constant Count_Type := Container.First;
530 Tree_Operations.Delete_Node_Sans_Free (Container, X);
531 Tree_Operations.Free (Container, X);
539 procedure Delete_Last (Container : in out Map) is
540 X : constant Count_Type := Container.Last;
544 Tree_Operations.Delete_Node_Sans_Free (Container, X);
545 Tree_Operations.Free (Container, X);
553 function Element (Position : Cursor) return Element_Type is
555 if Position.Node = 0 then
556 raise Constraint_Error with
557 "Position cursor of function Element equals No_Element";
560 pragma Assert (Vet (Position.Container.all, Position.Node),
561 "Position cursor of function Element is bad");
563 return Position.Container.Nodes (Position.Node).Element;
566 function Element (Container : Map; Key : Key_Type) return Element_Type is
567 Node : constant Count_Type := Key_Ops.Find (Container, Key);
570 raise Constraint_Error with "key not in map";
572 return Container.Nodes (Node).Element;
576 ---------------------
577 -- Equivalent_Keys --
578 ---------------------
580 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
595 procedure Exclude (Container : in out Map; Key : Key_Type) is
596 X : constant Count_Type := Key_Ops.Find (Container, Key);
600 Tree_Operations.Delete_Node_Sans_Free (Container, X);
601 Tree_Operations.Free (Container, X);
609 procedure Finalize (Object : in out Iterator) is
611 if Object.Container /= null then
613 B : Natural renames Object.Container.all.Busy;
624 function Find (Container : Map; Key : Key_Type) return Cursor is
625 Node : constant Count_Type := Key_Ops.Find (Container, Key);
630 return Cursor'(Container
'Unrestricted_Access, Node
);
638 function First
(Container
: Map
) return Cursor
is
640 if Container
.First
= 0 then
643 return Cursor
'(Container'Unrestricted_Access, Container.First);
647 function First (Object : Iterator) return Cursor is
649 -- The value of the iterator object's Node component influences the
650 -- behavior of the First (and Last) selector function.
652 -- When the Node component is 0, this means the iterator object was
653 -- constructed without a start expression, in which case the (forward)
654 -- iteration starts from the (logical) beginning of the entire sequence
655 -- of items (corresponding to Container.First, for a forward iterator).
657 -- Otherwise, this is iteration over a partial sequence of items. When
658 -- the Node component is positive, the iterator object was constructed
659 -- with a start expression, that specifies the position from which the
660 -- (forward) partial iteration begins.
662 if Object.Node = 0 then
663 return Bounded_Ordered_Maps.First (Object.Container.all);
665 return Cursor'(Object
.Container
, Object
.Node
);
673 function First_Element
(Container
: Map
) return Element_Type
is
675 if Container
.First
= 0 then
676 raise Constraint_Error
with "map is empty";
678 return Container
.Nodes
(Container
.First
).Element
;
686 function First_Key
(Container
: Map
) return Key_Type
is
688 if Container
.First
= 0 then
689 raise Constraint_Error
with "map is empty";
691 return Container
.Nodes
(Container
.First
).Key
;
699 function Floor
(Container
: Map
; Key
: Key_Type
) return Cursor
is
700 Node
: constant Count_Type
:= Key_Ops
.Floor
(Container
, Key
);
705 return Cursor
'(Container'Unrestricted_Access, Node);
713 function Has_Element (Position : Cursor) return Boolean is
715 return Position /= No_Element;
723 (Container : in out Map;
725 New_Item : Element_Type)
731 Insert (Container, Key, New_Item, Position, Inserted);
734 if Container.Lock > 0 then
735 raise Program_Error with
736 "attempt to tamper with elements (map is locked)";
740 N : Node_Type renames Container.Nodes (Position.Node);
743 N.Element := New_Item;
753 (Container : in out Map;
755 New_Item : Element_Type;
756 Position : out Cursor;
757 Inserted : out Boolean)
759 procedure Assign (Node : in out Node_Type);
760 pragma Inline (Assign);
762 function New_Node return Count_Type;
763 pragma Inline (New_Node);
765 procedure Insert_Post is
766 new Key_Ops.Generic_Insert_Post (New_Node);
768 procedure Insert_Sans_Hint is
769 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
771 procedure Allocate is
772 new Tree_Operations.Generic_Allocate (Assign);
778 procedure Assign (Node : in out Node_Type) is
781 Node.Element := New_Item;
788 function New_Node return Count_Type is
791 Allocate (Container, Result);
795 -- Start of processing for Insert
804 Position.Container := Container'Unrestricted_Access;
808 (Container : in out Map;
810 New_Item : Element_Type)
813 pragma Unreferenced (Position);
818 Insert (Container, Key, New_Item, Position, Inserted);
821 raise Constraint_Error with "key already in map";
826 (Container : in out Map;
828 Position : out Cursor;
829 Inserted : out Boolean)
831 procedure Assign (Node : in out Node_Type);
832 pragma Inline (Assign);
834 function New_Node return Count_Type;
835 pragma Inline (New_Node);
837 procedure Insert_Post is
838 new Key_Ops.Generic_Insert_Post (New_Node);
840 procedure Insert_Sans_Hint is
841 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
843 procedure Allocate is
844 new Tree_Operations.Generic_Allocate (Assign);
850 procedure Assign (Node : in out Node_Type) is
854 -- Were this insertion operation to accept an element parameter, this
855 -- is the point where the element value would be used, to update the
856 -- element component of the new node. However, this insertion
857 -- operation is special, in the sense that it does not accept an
858 -- element parameter. Rather, this version of Insert allocates a node
859 -- (inserting it among the active nodes of the container in the
860 -- normal way, with the node's position being determined by the Key),
861 -- and passes back a cursor designating the node. It is then up to
862 -- the caller to assign a value to the node's element.
864 -- Node.Element := New_Item;
871 function New_Node return Count_Type is
874 Allocate (Container, Result);
878 -- Start of processing for Insert
887 Position.Container := Container'Unrestricted_Access;
894 function Is_Empty (Container : Map) return Boolean is
896 return Container.Length = 0;
899 -------------------------
900 -- Is_Greater_Key_Node --
901 -------------------------
903 function Is_Greater_Key_Node
905 Right : Node_Type) return Boolean
908 -- Left > Right same as Right < Left
910 return Right.Key < Left;
911 end Is_Greater_Key_Node;
913 ----------------------
914 -- Is_Less_Key_Node --
915 ----------------------
917 function Is_Less_Key_Node
919 Right : Node_Type) return Boolean
922 return Left < Right.Key;
923 end Is_Less_Key_Node;
931 Process : not null access procedure (Position : Cursor))
933 procedure Process_Node (Node : Count_Type);
934 pragma Inline (Process_Node);
936 procedure Local_Iterate is
937 new Tree_Operations.Generic_Iteration (Process_Node);
943 procedure Process_Node (Node : Count_Type) is
945 Process (Cursor'(Container
'Unrestricted_Access, Node
));
948 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
950 -- Start of processing for Iterate
956 Local_Iterate
(Container
);
967 (Container
: Map
) return Map_Iterator_Interfaces
.Reversible_Iterator
'Class
969 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
972 -- The value of the Node component influences the behavior of the First
973 -- and Last selector functions of the iterator object. When the Node
974 -- component is 0 (as is the case here), this means the iterator object
975 -- was constructed without a start expression. This is a complete
976 -- iterator, meaning that the iteration starts from the (logical)
977 -- beginning of the sequence of items.
979 -- Note: For a forward iterator, Container.First is the beginning, and
980 -- for a reverse iterator, Container.Last is the beginning.
982 return It
: constant Iterator
:=
983 (Limited_Controlled
with
984 Container
=> Container
'Unrestricted_Access,
994 return Map_Iterator_Interfaces
.Reversible_Iterator
'Class
996 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
999 -- Iterator was defined to behave the same as for a complete iterator,
1000 -- and iterate over the entire sequence of items. However, those
1001 -- semantics were unintuitive and arguably error-prone (it is too easy
1002 -- to accidentally create an endless loop), and so they were changed,
1003 -- per the ARG meeting in Denver on 2011/11. However, there was no
1004 -- consensus about what positive meaning this corner case should have,
1005 -- and so it was decided to simply raise an exception. This does imply,
1006 -- however, that it is not possible to use a partial iterator to specify
1007 -- an empty sequence of items.
1009 if Start
= No_Element
then
1010 raise Constraint_Error
with
1011 "Start position for iterator equals No_Element";
1014 if Start
.Container
/= Container
'Unrestricted_Access then
1015 raise Program_Error
with
1016 "Start cursor of Iterate designates wrong map";
1019 pragma Assert
(Vet
(Container
, Start
.Node
),
1020 "Start cursor of Iterate is bad");
1022 -- The value of the Node component influences the behavior of the First
1023 -- and Last selector functions of the iterator object. When the Node
1024 -- component is positive (as is the case here), it means that this
1025 -- is a partial iteration, over a subset of the complete sequence of
1026 -- items. The iterator object was constructed with a start expression,
1027 -- indicating the position from which the iteration begins. (Note that
1028 -- the start position has the same value irrespective of whether this
1029 -- is a forward or reverse iteration.)
1031 return It
: constant Iterator
:=
1032 (Limited_Controlled
with
1033 Container
=> Container
'Unrestricted_Access,
1044 function Key
(Position
: Cursor
) return Key_Type
is
1046 if Position
.Node
= 0 then
1047 raise Constraint_Error
with
1048 "Position cursor of function Key equals No_Element";
1051 pragma Assert
(Vet
(Position
.Container
.all, Position
.Node
),
1052 "Position cursor of function Key is bad");
1054 return Position
.Container
.Nodes
(Position
.Node
).Key
;
1061 function Last
(Container
: Map
) return Cursor
is
1063 if Container
.Last
= 0 then
1066 return Cursor
'(Container'Unrestricted_Access, Container.Last);
1070 function Last (Object : Iterator) return Cursor is
1072 -- The value of the iterator object's Node component influences the
1073 -- behavior of the Last (and First) selector function.
1075 -- When the Node component is 0, this means the iterator object was
1076 -- constructed without a start expression, in which case the (reverse)
1077 -- iteration starts from the (logical) beginning of the entire sequence
1078 -- (corresponding to Container.Last, for a reverse iterator).
1080 -- Otherwise, this is iteration over a partial sequence of items. When
1081 -- the Node component is positive, the iterator object was constructed
1082 -- with a start expression, that specifies the position from which the
1083 -- (reverse) partial iteration begins.
1085 if Object.Node = 0 then
1086 return Bounded_Ordered_Maps.Last (Object.Container.all);
1088 return Cursor'(Object
.Container
, Object
.Node
);
1096 function Last_Element
(Container
: Map
) return Element_Type
is
1098 if Container
.Last
= 0 then
1099 raise Constraint_Error
with "map is empty";
1101 return Container
.Nodes
(Container
.Last
).Element
;
1109 function Last_Key
(Container
: Map
) return Key_Type
is
1111 if Container
.Last
= 0 then
1112 raise Constraint_Error
with "map is empty";
1114 return Container
.Nodes
(Container
.Last
).Key
;
1122 function Left
(Node
: Node_Type
) return Count_Type
is
1131 function Length
(Container
: Map
) return Count_Type
is
1133 return Container
.Length
;
1140 procedure Move
(Target
: in out Map
; Source
: in out Map
) is
1142 if Target
'Address = Source
'Address then
1146 if Source
.Busy
> 0 then
1147 raise Program_Error
with
1148 "attempt to tamper with cursors (container is busy)";
1151 Target
.Assign
(Source
);
1159 procedure Next
(Position
: in out Cursor
) is
1161 Position
:= Next
(Position
);
1164 function Next
(Position
: Cursor
) return Cursor
is
1166 if Position
= No_Element
then
1170 pragma Assert
(Vet
(Position
.Container
.all, Position
.Node
),
1171 "Position cursor of Next is bad");
1174 M
: Map
renames Position
.Container
.all;
1176 Node
: constant Count_Type
:=
1177 Tree_Operations
.Next
(M
, Position
.Node
);
1184 return Cursor
'(Position.Container, Node);
1190 Position : Cursor) return Cursor
1193 if Position.Container = null then
1197 if Position.Container /= Object.Container then
1198 raise Program_Error with
1199 "Position cursor of Next designates wrong map";
1202 return Next (Position);
1209 function Parent (Node : Node_Type) return Count_Type is
1218 procedure Previous (Position : in out Cursor) is
1220 Position := Previous (Position);
1223 function Previous (Position : Cursor) return Cursor is
1225 if Position = No_Element then
1229 pragma Assert (Vet (Position.Container.all, Position.Node),
1230 "Position cursor of Previous is bad");
1233 M : Map renames Position.Container.all;
1235 Node : constant Count_Type :=
1236 Tree_Operations.Previous (M, Position.Node);
1243 return Cursor'(Position
.Container
, Node
);
1249 Position
: Cursor
) return Cursor
1252 if Position
.Container
= null then
1256 if Position
.Container
/= Object
.Container
then
1257 raise Program_Error
with
1258 "Position cursor of Previous designates wrong map";
1261 return Previous
(Position
);
1268 procedure Query_Element
1270 Process
: not null access procedure (Key
: Key_Type
;
1271 Element
: Element_Type
))
1274 if Position
.Node
= 0 then
1275 raise Constraint_Error
with
1276 "Position cursor of Query_Element equals No_Element";
1279 pragma Assert
(Vet
(Position
.Container
.all, Position
.Node
),
1280 "Position cursor of Query_Element is bad");
1283 M
: Map
renames Position
.Container
.all;
1284 N
: Node_Type
renames M
.Nodes
(Position
.Node
);
1286 B
: Natural renames M
.Busy
;
1287 L
: Natural renames M
.Lock
;
1294 Process
(N
.Key
, N
.Element
);
1312 (Stream
: not null access Root_Stream_Type
'Class;
1313 Container
: out Map
)
1315 procedure Read_Element
(Node
: in out Node_Type
);
1316 pragma Inline
(Read_Element
);
1318 procedure Allocate
is
1319 new Tree_Operations
.Generic_Allocate
(Read_Element
);
1321 procedure Read_Elements
is
1322 new Tree_Operations
.Generic_Read
(Allocate
);
1328 procedure Read_Element
(Node
: in out Node_Type
) is
1330 Key_Type
'Read (Stream
, Node
.Key
);
1331 Element_Type
'Read (Stream
, Node
.Element
);
1334 -- Start of processing for Read
1337 Read_Elements
(Stream
, Container
);
1341 (Stream
: not null access Root_Stream_Type
'Class;
1345 raise Program_Error
with "attempt to stream map cursor";
1349 (Stream
: not null access Root_Stream_Type
'Class;
1350 Item
: out Reference_Type
)
1353 raise Program_Error
with "attempt to stream reference";
1357 (Stream
: not null access Root_Stream_Type
'Class;
1358 Item
: out Constant_Reference_Type
)
1361 raise Program_Error
with "attempt to stream reference";
1369 (Container
: aliased in out Map
;
1370 Position
: Cursor
) return Reference_Type
1373 if Position
.Container
= null then
1374 raise Constraint_Error
with
1375 "Position cursor has no element";
1378 if Position
.Container
/= Container
'Unrestricted_Access then
1379 raise Program_Error
with
1380 "Position cursor designates wrong map";
1383 pragma Assert
(Vet
(Container
, Position
.Node
),
1384 "Position cursor in function Reference is bad");
1387 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
1389 return (Element
=> N
.Element
'Access);
1394 (Container
: aliased in out Map
;
1395 Key
: Key_Type
) return Reference_Type
1397 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
1401 raise Constraint_Error
with "key not in map";
1405 N
: Node_Type
renames Container
.Nodes
(Node
);
1407 return (Element
=> N
.Element
'Access);
1416 (Container
: in out Map
;
1418 New_Item
: Element_Type
)
1420 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
1424 raise Constraint_Error
with "key not in map";
1427 if Container
.Lock
> 0 then
1428 raise Program_Error
with
1429 "attempt to tamper with elements (map is locked)";
1433 N
: Node_Type
renames Container
.Nodes
(Node
);
1437 N
.Element
:= New_Item
;
1441 ---------------------
1442 -- Replace_Element --
1443 ---------------------
1445 procedure Replace_Element
1446 (Container
: in out Map
;
1448 New_Item
: Element_Type
)
1451 if Position
.Node
= 0 then
1452 raise Constraint_Error
with
1453 "Position cursor of Replace_Element equals No_Element";
1456 if Position
.Container
/= Container
'Unrestricted_Access then
1457 raise Program_Error
with
1458 "Position cursor of Replace_Element designates wrong map";
1461 if Container
.Lock
> 0 then
1462 raise Program_Error
with
1463 "attempt to tamper with elements (map is locked)";
1466 pragma Assert
(Vet
(Container
, Position
.Node
),
1467 "Position cursor of Replace_Element is bad");
1469 Container
.Nodes
(Position
.Node
).Element
:= New_Item
;
1470 end Replace_Element
;
1472 ---------------------
1473 -- Reverse_Iterate --
1474 ---------------------
1476 procedure Reverse_Iterate
1478 Process
: not null access procedure (Position
: Cursor
))
1480 procedure Process_Node
(Node
: Count_Type
);
1481 pragma Inline
(Process_Node
);
1483 procedure Local_Reverse_Iterate
is
1484 new Tree_Operations
.Generic_Reverse_Iteration
(Process_Node
);
1490 procedure Process_Node
(Node
: Count_Type
) is
1492 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1495 B : Natural renames Container'Unrestricted_Access.all.Busy;
1497 -- Start of processing for Reverse_Iterate
1503 Local_Reverse_Iterate (Container);
1511 end Reverse_Iterate;
1517 function Right (Node : Node_Type) return Count_Type is
1527 (Node : in out Node_Type;
1531 Node.Color := Color;
1538 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
1547 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
1549 Node.Parent := Parent;
1556 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
1558 Node.Right := Right;
1561 --------------------
1562 -- Update_Element --
1563 --------------------
1565 procedure Update_Element
1566 (Container : in out Map;
1568 Process : not null access procedure (Key : Key_Type;
1569 Element : in out Element_Type))
1572 if Position.Node = 0 then
1573 raise Constraint_Error with
1574 "Position cursor of Update_Element equals No_Element";
1577 if Position.Container /= Container'Unrestricted_Access then
1578 raise Program_Error with
1579 "Position cursor of Update_Element designates wrong map";
1582 pragma Assert (Vet (Container, Position.Node),
1583 "Position cursor of Update_Element is bad");
1586 N : Node_Type renames Container.Nodes (Position.Node);
1587 B : Natural renames Container.Busy;
1588 L : Natural renames Container.Lock;
1595 Process (N.Key, N.Element);
1614 (Stream : not null access Root_Stream_Type'Class;
1617 procedure Write_Node
1618 (Stream : not null access Root_Stream_Type'Class;
1620 pragma Inline (Write_Node);
1622 procedure Write_Nodes is
1623 new Tree_Operations.Generic_Write (Write_Node);
1629 procedure Write_Node
1630 (Stream : not null access Root_Stream_Type'Class;
1634 Key_Type'Write (Stream, Node.Key);
1635 Element_Type'Write (Stream, Node.Element);
1638 -- Start of processing for Write
1641 Write_Nodes (Stream, Container);
1645 (Stream : not null access Root_Stream_Type'Class;
1649 raise Program_Error with "attempt to stream map cursor";
1653 (Stream : not null access Root_Stream_Type'Class;
1654 Item : Reference_Type)
1657 raise Program_Error with "attempt to stream reference";
1661 (Stream : not null access Root_Stream_Type'Class;
1662 Item : Constant_Reference_Type)
1665 raise Program_Error with "attempt to stream reference";
1668 end Ada.Containers.Bounded_Ordered_Maps;