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-2024, 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
.Helpers
; use Ada
.Containers
.Helpers
;
32 with Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Operations
;
34 (Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Operations
);
36 with Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Keys
;
38 (Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Keys
);
40 with System
; use type System
.Address
;
41 with System
.Put_Images
;
43 package body Ada
.Containers
.Bounded_Ordered_Maps
with
47 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
48 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
49 -- See comment in Ada.Containers.Helpers
51 -----------------------------
52 -- Node Access Subprograms --
53 -----------------------------
55 -- These subprograms provide a functional interface to access fields
56 -- of a node, and a procedural interface for modifying these values.
58 function Color
(Node
: Node_Type
) return Color_Type
;
59 pragma Inline
(Color
);
61 function Left
(Node
: Node_Type
) return Count_Type
;
64 function Parent
(Node
: Node_Type
) return Count_Type
;
65 pragma Inline
(Parent
);
67 function Right
(Node
: Node_Type
) return Count_Type
;
68 pragma Inline
(Right
);
70 procedure Set_Parent
(Node
: in out Node_Type
; Parent
: Count_Type
);
71 pragma Inline
(Set_Parent
);
73 procedure Set_Left
(Node
: in out Node_Type
; Left
: Count_Type
);
74 pragma Inline
(Set_Left
);
76 procedure Set_Right
(Node
: in out Node_Type
; Right
: Count_Type
);
77 pragma Inline
(Set_Right
);
79 procedure Set_Color
(Node
: in out Node_Type
; Color
: Color_Type
);
80 pragma Inline
(Set_Color
);
82 -----------------------
83 -- Local Subprograms --
84 -----------------------
86 function Is_Greater_Key_Node
88 Right
: Node_Type
) return Boolean;
89 pragma Inline
(Is_Greater_Key_Node
);
91 function Is_Less_Key_Node
93 Right
: Node_Type
) return Boolean;
94 pragma Inline
(Is_Less_Key_Node
);
96 --------------------------
97 -- Local Instantiations --
98 --------------------------
100 package Tree_Operations
is
101 new Red_Black_Trees
.Generic_Bounded_Operations
(Tree_Types
);
106 new Red_Black_Trees
.Generic_Bounded_Keys
107 (Tree_Operations
=> Tree_Operations
,
108 Key_Type
=> Key_Type
,
109 Is_Less_Key_Node
=> Is_Less_Key_Node
,
110 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
116 function "<" (Left
, Right
: Cursor
) return Boolean is
118 if Checks
and then Left
.Node
= 0 then
119 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
122 if Checks
and then Right
.Node
= 0 then
123 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
126 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
127 "Left cursor of ""<"" is bad");
129 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
130 "Right cursor of ""<"" is bad");
133 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
134 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
137 return LN
.Key
< RN
.Key
;
141 function "<" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
143 if Checks
and then Left
.Node
= 0 then
144 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
147 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
148 "Left cursor of ""<"" is bad");
151 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
154 return LN
.Key
< Right
;
158 function "<" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
160 if Checks
and then Right
.Node
= 0 then
161 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
164 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
165 "Right cursor of ""<"" is bad");
168 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
171 return Left
< RN
.Key
;
179 function "=" (Left
, Right
: Map
) return Boolean is
180 function Is_Equal_Node_Node
(L
, R
: Node_Type
) return Boolean;
181 pragma Inline
(Is_Equal_Node_Node
);
184 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
186 ------------------------
187 -- Is_Equal_Node_Node --
188 ------------------------
190 function Is_Equal_Node_Node
191 (L
, R
: Node_Type
) return Boolean is
193 if L
.Key
< R
.Key
then
196 elsif R
.Key
< L
.Key
then
200 return L
.Element
= R
.Element
;
202 end Is_Equal_Node_Node
;
204 -- Start of processing for "="
207 return Is_Equal
(Left
, Right
);
214 function ">" (Left
, Right
: Cursor
) return Boolean is
216 if Checks
and then Left
.Node
= 0 then
217 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
220 if Checks
and then Right
.Node
= 0 then
221 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
224 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
225 "Left cursor of "">"" is bad");
227 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
228 "Right cursor of "">"" is bad");
231 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
232 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
235 return RN
.Key
< LN
.Key
;
239 function ">" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
241 if Checks
and then Left
.Node
= 0 then
242 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
245 pragma Assert
(Vet
(Left
.Container
.all, Left
.Node
),
246 "Left cursor of "">"" is bad");
249 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
251 return Right
< LN
.Key
;
255 function ">" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
257 if Checks
and then Right
.Node
= 0 then
258 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
261 pragma Assert
(Vet
(Right
.Container
.all, Right
.Node
),
262 "Right cursor of "">"" is bad");
265 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
268 return RN
.Key
< Left
;
276 procedure Assign
(Target
: in out Map
; Source
: Map
) is
277 procedure Append_Element
(Source_Node
: Count_Type
);
279 procedure Append_Elements
is
280 new Tree_Operations
.Generic_Iteration
(Append_Element
);
286 procedure Append_Element
(Source_Node
: Count_Type
) is
287 SN
: Node_Type
renames Source
.Nodes
(Source_Node
);
289 procedure Set_Element
(Node
: in out Node_Type
);
290 pragma Inline
(Set_Element
);
292 function New_Node
return Count_Type
;
293 pragma Inline
(New_Node
);
295 procedure Insert_Post
is
296 new Key_Ops
.Generic_Insert_Post
(New_Node
);
298 procedure Unconditional_Insert_Sans_Hint
is
299 new Key_Ops
.Generic_Unconditional_Insert
(Insert_Post
);
301 procedure Unconditional_Insert_Avec_Hint
is
302 new Key_Ops
.Generic_Unconditional_Insert_With_Hint
304 Unconditional_Insert_Sans_Hint
);
306 procedure Allocate
is
307 new Tree_Operations
.Generic_Allocate
(Set_Element
);
313 function New_Node
return Count_Type
is
317 Allocate
(Target
, Result
);
325 procedure Set_Element
(Node
: in out Node_Type
) is
328 Node
.Element
:= SN
.Element
;
331 Target_Node
: Count_Type
;
333 -- Start of processing for Append_Element
336 Unconditional_Insert_Avec_Hint
340 Node
=> Target_Node
);
343 -- Start of processing for Assign
346 if Target
'Address = Source
'Address then
350 if Checks
and then Target
.Capacity
< Source
.Length
then
352 with "Target capacity is less than Source length";
355 Tree_Operations
.Clear_Tree
(Target
);
356 Append_Elements
(Source
);
363 function Ceiling
(Container
: Map
; Key
: Key_Type
) return Cursor
is
364 Node
: constant Count_Type
:= Key_Ops
.Ceiling
(Container
, Key
);
371 return Cursor
'(Container'Unrestricted_Access, Node);
378 procedure Clear (Container : in out Map) is
380 while not Container.Is_Empty loop
381 Container.Delete_Last;
389 function Color (Node : Node_Type) return Color_Type is
394 ------------------------
395 -- Constant_Reference --
396 ------------------------
398 function Constant_Reference
399 (Container : aliased Map;
400 Position : Cursor) return Constant_Reference_Type
403 if Checks and then Position.Container = null then
404 raise Constraint_Error with
405 "Position cursor has no element";
408 if Checks and then Position.Container /= Container'Unrestricted_Access
410 raise Program_Error with
411 "Position cursor designates wrong map";
414 pragma Assert (Vet (Container, Position.Node),
415 "Position cursor in Constant_Reference is bad");
418 N : Node_Type renames Container.Nodes (Position.Node);
419 TC : constant Tamper_Counts_Access :=
420 Container.TC'Unrestricted_Access;
422 return R : constant Constant_Reference_Type :=
423 (Element => N.Element'Unchecked_Access,
424 Control => (Controlled with TC))
429 end Constant_Reference;
431 function Constant_Reference
432 (Container : aliased Map;
433 Key : Key_Type) return Constant_Reference_Type
435 Node : constant Count_Type := Key_Ops.Find (Container, Key);
438 if Checks and then Node = 0 then
439 raise Constraint_Error with "key not in map";
443 N : Node_Type renames Container.Nodes (Node);
444 TC : constant Tamper_Counts_Access :=
445 Container.TC'Unrestricted_Access;
447 return R : constant Constant_Reference_Type :=
448 (Element => N.Element'Unchecked_Access,
449 Control => (Controlled with TC))
454 end Constant_Reference;
460 function Contains (Container : Map; Key : Key_Type) return Boolean is
462 return Find (Container, Key) /= No_Element;
469 function Copy (Source : Map; Capacity : Count_Type := 0) return Map is
470 C : constant Count_Type :=
471 (if Capacity = 0 then Source.Length
474 if Checks and then C < Source.Length then
475 raise Capacity_Error with "Capacity too small";
478 return Target : Map (Capacity => C) do
479 Assign (Target => Target, Source => Source);
487 procedure Delete (Container : in out Map; Position : in out Cursor) is
489 if Checks and then Position.Node = 0 then
490 raise Constraint_Error with
491 "Position cursor of Delete equals No_Element";
494 if Checks and then Position.Container /= Container'Unrestricted_Access
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);
513 if Checks and then X = 0 then
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 Checks and then 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);
569 if Checks and then Node = 0 then
570 raise Constraint_Error with "key not in map";
573 return Container.Nodes (Node).Element;
580 function Empty (Capacity : Count_Type := 10) return Map is
582 return Result : Map (Capacity) do
587 ---------------------
588 -- Equivalent_Keys --
589 ---------------------
591 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
606 procedure Exclude (Container : in out Map; Key : Key_Type) is
607 X : constant Count_Type := Key_Ops.Find (Container, Key);
611 Tree_Operations.Delete_Node_Sans_Free (Container, X);
612 Tree_Operations.Free (Container, X);
620 procedure Finalize (Object : in out Iterator) is
622 if Object.Container /= null then
623 Unbusy (Object.Container.TC);
631 function Find (Container : Map; Key : Key_Type) return Cursor is
632 Node : constant Count_Type := Key_Ops.Find (Container, Key);
637 return Cursor'(Container
'Unrestricted_Access, Node
);
645 function First
(Container
: Map
) return Cursor
is
647 if Container
.First
= 0 then
650 return Cursor
'(Container'Unrestricted_Access, Container.First);
654 function First (Object : Iterator) return Cursor is
656 -- The value of the iterator object's Node component influences the
657 -- behavior of the First (and Last) selector function.
659 -- When the Node component is 0, this means the iterator object was
660 -- constructed without a start expression, in which case the (forward)
661 -- iteration starts from the (logical) beginning of the entire sequence
662 -- of items (corresponding to Container.First, for a forward iterator).
664 -- Otherwise, this is iteration over a partial sequence of items. When
665 -- the Node component is positive, the iterator object was constructed
666 -- with a start expression, that specifies the position from which the
667 -- (forward) partial iteration begins.
669 if Object.Node = 0 then
670 return Bounded_Ordered_Maps.First (Object.Container.all);
672 return Cursor'(Object
.Container
, Object
.Node
);
680 function First_Element
(Container
: Map
) return Element_Type
is
682 if Checks
and then Container
.First
= 0 then
683 raise Constraint_Error
with "map is empty";
686 return Container
.Nodes
(Container
.First
).Element
;
693 function First_Key
(Container
: Map
) return Key_Type
is
695 if Checks
and then Container
.First
= 0 then
696 raise Constraint_Error
with "map is empty";
699 return Container
.Nodes
(Container
.First
).Key
;
706 function Floor
(Container
: Map
; Key
: Key_Type
) return Cursor
is
707 Node
: constant Count_Type
:= Key_Ops
.Floor
(Container
, Key
);
712 return Cursor
'(Container'Unrestricted_Access, Node);
716 ------------------------
717 -- Get_Element_Access --
718 ------------------------
720 function Get_Element_Access
721 (Position : Cursor) return not null Element_Access is
723 return Position.Container.Nodes (Position.Node).Element'Access;
724 end Get_Element_Access;
730 function Has_Element (Position : Cursor) return Boolean is
732 return Position /= No_Element;
740 (Container : in out Map;
742 New_Item : Element_Type)
748 Insert (Container, Key, New_Item, Position, Inserted);
751 TE_Check (Container.TC);
754 N : Node_Type renames Container.Nodes (Position.Node);
757 N.Element := New_Item;
767 (Container : in out Map;
769 New_Item : Element_Type;
770 Position : out Cursor;
771 Inserted : out Boolean)
773 procedure Assign (Node : in out Node_Type);
774 pragma Inline (Assign);
776 function New_Node return Count_Type;
777 pragma Inline (New_Node);
779 procedure Insert_Post is
780 new Key_Ops.Generic_Insert_Post (New_Node);
782 procedure Insert_Sans_Hint is
783 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
785 procedure Allocate is
786 new Tree_Operations.Generic_Allocate (Assign);
792 procedure Assign (Node : in out Node_Type) is
795 Node.Element := New_Item;
802 function New_Node return Count_Type is
805 Allocate (Container, Result);
809 -- Start of processing for Insert
818 Position.Container := Container'Unrestricted_Access;
822 (Container : in out Map;
824 New_Item : Element_Type)
830 Insert (Container, Key, New_Item, Position, Inserted);
832 if Checks and then not Inserted then
833 raise Constraint_Error with "key already in map";
838 (Container : in out Map;
840 Position : out Cursor;
841 Inserted : out Boolean)
843 procedure Assign (Node : in out Node_Type);
844 pragma Inline (Assign);
846 function New_Node return Count_Type;
847 pragma Inline (New_Node);
849 procedure Insert_Post is
850 new Key_Ops.Generic_Insert_Post (New_Node);
852 procedure Insert_Sans_Hint is
853 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
855 procedure Allocate is
856 new Tree_Operations.Generic_Allocate (Assign);
862 procedure Assign (Node : in out Node_Type) is
863 pragma Warnings (Off);
864 Default_Initialized_Item : Element_Type;
865 pragma Unmodified (Default_Initialized_Item);
866 -- Default-initialized element (ok to reference, see below)
871 -- There is no explicit element provided, but in an instance the element
872 -- type may be a scalar with a Default_Value aspect, or a composite type
873 -- with such a scalar component or with defaulted components, so insert
874 -- possibly initialized elements at the given position.
876 Node.Element := Default_Initialized_Item;
877 pragma Warnings (On);
884 function New_Node return Count_Type is
887 Allocate (Container, Result);
891 -- Start of processing for Insert
900 Position.Container := Container'Unrestricted_Access;
907 function Is_Empty (Container : Map) return Boolean is
909 return Container.Length = 0;
912 -------------------------
913 -- Is_Greater_Key_Node --
914 -------------------------
916 function Is_Greater_Key_Node
918 Right : Node_Type) return Boolean
921 -- Left > Right same as Right < Left
923 return Right.Key < Left;
924 end Is_Greater_Key_Node;
926 ----------------------
927 -- Is_Less_Key_Node --
928 ----------------------
930 function Is_Less_Key_Node
932 Right : Node_Type) return Boolean
935 return Left < Right.Key;
936 end Is_Less_Key_Node;
944 Process : not null access procedure (Position : Cursor))
946 procedure Process_Node (Node : Count_Type);
947 pragma Inline (Process_Node);
949 procedure Local_Iterate is
950 new Tree_Operations.Generic_Iteration (Process_Node);
956 procedure Process_Node (Node : Count_Type) is
958 Process (Cursor'(Container
'Unrestricted_Access, Node
));
961 Busy
: With_Busy
(Container
.TC
'Unrestricted_Access);
963 -- Start of processing for Iterate
966 Local_Iterate
(Container
);
970 (Container
: Map
) return Map_Iterator_Interfaces
.Reversible_Iterator
'Class
973 -- The value of the Node component influences the behavior of the First
974 -- and Last selector functions of the iterator object. When the Node
975 -- component is 0 (as is the case here), this means the iterator object
976 -- was constructed without a start expression. This is a complete
977 -- iterator, meaning that the iteration starts from the (logical)
978 -- beginning of the sequence of items.
980 -- Note: For a forward iterator, Container.First is the beginning, and
981 -- for a reverse iterator, Container.Last is the beginning.
983 return It
: constant Iterator
:=
984 (Limited_Controlled
with
985 Container
=> Container
'Unrestricted_Access,
988 Busy
(Container
.TC
'Unrestricted_Access.all);
995 return Map_Iterator_Interfaces
.Reversible_Iterator
'Class
998 -- Iterator was defined to behave the same as for a complete iterator,
999 -- and iterate over the entire sequence of items. However, those
1000 -- semantics were unintuitive and arguably error-prone (it is too easy
1001 -- to accidentally create an endless loop), and so they were changed,
1002 -- per the ARG meeting in Denver on 2011/11. However, there was no
1003 -- consensus about what positive meaning this corner case should have,
1004 -- and so it was decided to simply raise an exception. This does imply,
1005 -- however, that it is not possible to use a partial iterator to specify
1006 -- an empty sequence of items.
1008 if Checks
and then Start
= No_Element
then
1009 raise Constraint_Error
with
1010 "Start position for iterator equals No_Element";
1013 if Checks
and then Start
.Container
/= Container
'Unrestricted_Access then
1014 raise Program_Error
with
1015 "Start cursor of Iterate designates wrong map";
1018 pragma Assert
(Vet
(Container
, Start
.Node
),
1019 "Start cursor of Iterate is bad");
1021 -- The value of the Node component influences the behavior of the First
1022 -- and Last selector functions of the iterator object. When the Node
1023 -- component is positive (as is the case here), it means that this
1024 -- is a partial iteration, over a subset of the complete sequence of
1025 -- items. The iterator object was constructed with a start expression,
1026 -- indicating the position from which the iteration begins. (Note that
1027 -- the start position has the same value irrespective of whether this
1028 -- is a forward or reverse iteration.)
1030 return It
: constant Iterator
:=
1031 (Limited_Controlled
with
1032 Container
=> Container
'Unrestricted_Access,
1035 Busy
(Container
.TC
'Unrestricted_Access.all);
1043 function Key
(Position
: Cursor
) return Key_Type
is
1045 if Checks
and then Position
.Node
= 0 then
1046 raise Constraint_Error
with
1047 "Position cursor of function Key equals No_Element";
1050 pragma Assert
(Vet
(Position
.Container
.all, Position
.Node
),
1051 "Position cursor of function Key is bad");
1053 return Position
.Container
.Nodes
(Position
.Node
).Key
;
1060 function Last
(Container
: Map
) return Cursor
is
1062 if Container
.Last
= 0 then
1065 return Cursor
'(Container'Unrestricted_Access, Container.Last);
1069 function Last (Object : Iterator) return Cursor is
1071 -- The value of the iterator object's Node component influences the
1072 -- behavior of the Last (and First) selector function.
1074 -- When the Node component is 0, this means the iterator object was
1075 -- constructed without a start expression, in which case the (reverse)
1076 -- iteration starts from the (logical) beginning of the entire sequence
1077 -- (corresponding to Container.Last, for a reverse iterator).
1079 -- Otherwise, this is iteration over a partial sequence of items. When
1080 -- the Node component is positive, the iterator object was constructed
1081 -- with a start expression, that specifies the position from which the
1082 -- (reverse) partial iteration begins.
1084 if Object.Node = 0 then
1085 return Bounded_Ordered_Maps.Last (Object.Container.all);
1087 return Cursor'(Object
.Container
, Object
.Node
);
1095 function Last_Element
(Container
: Map
) return Element_Type
is
1097 if Checks
and then Container
.Last
= 0 then
1098 raise Constraint_Error
with "map is empty";
1101 return Container
.Nodes
(Container
.Last
).Element
;
1108 function Last_Key
(Container
: Map
) return Key_Type
is
1110 if Checks
and then Container
.Last
= 0 then
1111 raise Constraint_Error
with "map is empty";
1114 return Container
.Nodes
(Container
.Last
).Key
;
1121 function Left
(Node
: Node_Type
) return Count_Type
is
1130 function Length
(Container
: Map
) return Count_Type
is
1132 return Container
.Length
;
1139 procedure Move
(Target
: in out Map
; Source
: in out Map
) is
1141 if Target
'Address = Source
'Address then
1145 TC_Check
(Source
.TC
);
1147 Target
.Assign
(Source
);
1155 procedure Next
(Position
: in out Cursor
) is
1157 Position
:= Next
(Position
);
1160 function Next
(Position
: Cursor
) return Cursor
is
1162 if Position
= No_Element
then
1166 pragma Assert
(Vet
(Position
.Container
.all, Position
.Node
),
1167 "Position cursor of Next is bad");
1170 M
: Map
renames Position
.Container
.all;
1172 Node
: constant Count_Type
:=
1173 Tree_Operations
.Next
(M
, Position
.Node
);
1180 return Cursor
'(Position.Container, Node);
1186 Position : Cursor) return Cursor
1189 if Position.Container = null then
1193 if Checks and then Position.Container /= Object.Container then
1194 raise Program_Error with
1195 "Position cursor of Next designates wrong map";
1198 return Next (Position);
1205 function Parent (Node : Node_Type) return Count_Type is
1214 procedure Previous (Position : in out Cursor) is
1216 Position := Previous (Position);
1219 function Previous (Position : Cursor) return Cursor is
1221 if Position = No_Element then
1225 pragma Assert (Vet (Position.Container.all, Position.Node),
1226 "Position cursor of Previous is bad");
1229 M : Map renames Position.Container.all;
1231 Node : constant Count_Type :=
1232 Tree_Operations.Previous (M, Position.Node);
1239 return Cursor'(Position
.Container
, Node
);
1245 Position
: Cursor
) return Cursor
1248 if Position
.Container
= null then
1252 if Checks
and then Position
.Container
/= Object
.Container
then
1253 raise Program_Error
with
1254 "Position cursor of Previous designates wrong map";
1257 return Previous
(Position
);
1260 ----------------------
1261 -- Pseudo_Reference --
1262 ----------------------
1264 function Pseudo_Reference
1265 (Container
: aliased Map
'Class) return Reference_Control_Type
1267 TC
: constant Tamper_Counts_Access
:=
1268 Container
.TC
'Unrestricted_Access;
1270 return R
: constant Reference_Control_Type
:= (Controlled
with TC
) do
1273 end Pseudo_Reference
;
1279 procedure Query_Element
1281 Process
: not null access procedure (Key
: Key_Type
;
1282 Element
: Element_Type
))
1285 if Checks
and then Position
.Node
= 0 then
1286 raise Constraint_Error
with
1287 "Position cursor of Query_Element equals No_Element";
1290 pragma Assert
(Vet
(Position
.Container
.all, Position
.Node
),
1291 "Position cursor of Query_Element is bad");
1294 M
: Map
renames Position
.Container
.all;
1295 N
: Node_Type
renames M
.Nodes
(Position
.Node
);
1296 Lock
: With_Lock
(M
.TC
'Unrestricted_Access);
1298 Process
(N
.Key
, N
.Element
);
1307 (S
: in out Ada
.Strings
.Text_Buffers
.Root_Buffer_Type
'Class; V
: Map
)
1309 First_Time
: Boolean := True;
1310 use System
.Put_Images
;
1312 procedure Put_Key_Value
(Position
: Cursor
);
1313 procedure Put_Key_Value
(Position
: Cursor
) is
1316 First_Time
:= False;
1318 Simple_Array_Between
(S
);
1321 Key_Type
'Put_Image (S
, Key
(Position
));
1323 Element_Type
'Put_Image (S
, Element
(Position
));
1328 Iterate
(V
, Put_Key_Value
'Access);
1337 (Stream
: not null access Root_Stream_Type
'Class;
1338 Container
: out Map
)
1340 procedure Read_Element
(Node
: in out Node_Type
);
1341 pragma Inline
(Read_Element
);
1343 procedure Allocate
is
1344 new Tree_Operations
.Generic_Allocate
(Read_Element
);
1346 procedure Read_Elements
is
1347 new Tree_Operations
.Generic_Read
(Allocate
);
1353 procedure Read_Element
(Node
: in out Node_Type
) is
1355 Key_Type
'Read (Stream
, Node
.Key
);
1356 Element_Type
'Read (Stream
, Node
.Element
);
1359 -- Start of processing for Read
1362 Read_Elements
(Stream
, Container
);
1366 (Stream
: not null access Root_Stream_Type
'Class;
1370 raise Program_Error
with "attempt to stream map cursor";
1374 (Stream
: not null access Root_Stream_Type
'Class;
1375 Item
: out Reference_Type
)
1378 raise Program_Error
with "attempt to stream reference";
1382 (Stream
: not null access Root_Stream_Type
'Class;
1383 Item
: out Constant_Reference_Type
)
1386 raise Program_Error
with "attempt to stream reference";
1394 (Container
: aliased in out Map
;
1395 Position
: Cursor
) return Reference_Type
1398 if Checks
and then Position
.Container
= null then
1399 raise Constraint_Error
with
1400 "Position cursor has no element";
1403 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
1405 raise Program_Error
with
1406 "Position cursor designates wrong map";
1409 pragma Assert
(Vet
(Container
, Position
.Node
),
1410 "Position cursor in function Reference is bad");
1413 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
1414 TC
: constant Tamper_Counts_Access
:=
1415 Container
.TC
'Unrestricted_Access;
1417 return R
: constant Reference_Type
:=
1418 (Element
=> N
.Element
'Unchecked_Access,
1419 Control
=> (Controlled
with TC
))
1427 (Container
: aliased in out Map
;
1428 Key
: Key_Type
) return Reference_Type
1430 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
1433 if Checks
and then Node
= 0 then
1434 raise Constraint_Error
with "key not in map";
1438 N
: Node_Type
renames Container
.Nodes
(Node
);
1439 TC
: constant Tamper_Counts_Access
:=
1440 Container
.TC
'Unrestricted_Access;
1442 return R
: constant Reference_Type
:=
1443 (Element
=> N
.Element
'Unchecked_Access,
1444 Control
=> (Controlled
with TC
))
1456 (Container
: in out Map
;
1458 New_Item
: Element_Type
)
1460 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
1463 TE_Check
(Container
.TC
);
1465 if Checks
and then Node
= 0 then
1466 raise Constraint_Error
with "key not in map";
1470 N
: Node_Type
renames Container
.Nodes
(Node
);
1474 N
.Element
:= New_Item
;
1478 ---------------------
1479 -- Replace_Element --
1480 ---------------------
1482 procedure Replace_Element
1483 (Container
: in out Map
;
1485 New_Item
: Element_Type
)
1488 TE_Check
(Container
.TC
);
1490 if Checks
and then Position
.Node
= 0 then
1491 raise Constraint_Error
with
1492 "Position cursor of Replace_Element equals No_Element";
1495 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
1497 raise Program_Error
with
1498 "Position cursor of Replace_Element designates wrong map";
1501 pragma Assert
(Vet
(Container
, Position
.Node
),
1502 "Position cursor of Replace_Element is bad");
1504 Container
.Nodes
(Position
.Node
).Element
:= New_Item
;
1505 end Replace_Element
;
1507 ---------------------
1508 -- Reverse_Iterate --
1509 ---------------------
1511 procedure Reverse_Iterate
1513 Process
: not null access procedure (Position
: Cursor
))
1515 procedure Process_Node
(Node
: Count_Type
);
1516 pragma Inline
(Process_Node
);
1518 procedure Local_Reverse_Iterate
is
1519 new Tree_Operations
.Generic_Reverse_Iteration
(Process_Node
);
1525 procedure Process_Node
(Node
: Count_Type
) is
1527 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1530 Busy : With_Busy (Container.TC'Unrestricted_Access);
1532 -- Start of processing for Reverse_Iterate
1535 Local_Reverse_Iterate (Container);
1536 end Reverse_Iterate;
1542 function Right (Node : Node_Type) return Count_Type is
1552 (Node : in out Node_Type;
1556 Node.Color := Color;
1563 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
1572 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
1574 Node.Parent := Parent;
1581 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
1583 Node.Right := Right;
1586 --------------------
1587 -- Update_Element --
1588 --------------------
1590 procedure Update_Element
1591 (Container : in out Map;
1593 Process : not null access procedure (Key : Key_Type;
1594 Element : in out Element_Type))
1597 if Checks and then Position.Node = 0 then
1598 raise Constraint_Error with
1599 "Position cursor of Update_Element equals No_Element";
1602 if Checks and then Position.Container /= Container'Unrestricted_Access
1604 raise Program_Error with
1605 "Position cursor of Update_Element designates wrong map";
1608 pragma Assert (Vet (Container, Position.Node),
1609 "Position cursor of Update_Element is bad");
1612 N : Node_Type renames Container.Nodes (Position.Node);
1613 Lock : With_Lock (Container.TC'Unrestricted_Access);
1615 Process (N.Key, N.Element);
1624 (Stream : not null access Root_Stream_Type'Class;
1627 procedure Write_Node
1628 (Stream : not null access Root_Stream_Type'Class;
1630 pragma Inline (Write_Node);
1632 procedure Write_Nodes is
1633 new Tree_Operations.Generic_Write (Write_Node);
1639 procedure Write_Node
1640 (Stream : not null access Root_Stream_Type'Class;
1644 Key_Type'Write (Stream, Node.Key);
1645 Element_Type'Write (Stream, Node.Element);
1648 -- Start of processing for Write
1651 Write_Nodes (Stream, Container);
1655 (Stream : not null access Root_Stream_Type'Class;
1659 raise Program_Error with "attempt to stream map cursor";
1663 (Stream : not null access Root_Stream_Type'Class;
1664 Item : Reference_Type)
1667 raise Program_Error with "attempt to stream reference";
1671 (Stream : not null access Root_Stream_Type'Class;
1672 Item : Constant_Reference_Type)
1675 raise Program_Error with "attempt to stream reference";
1678 end Ada.Containers.Bounded_Ordered_Maps;