1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
9 -- Copyright (C) 2004-2023, 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
.Helpers
; use Ada
.Containers
.Helpers
;
34 with Ada
.Containers
.Red_Black_Trees
.Generic_Operations
;
35 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Operations
);
37 with Ada
.Containers
.Red_Black_Trees
.Generic_Keys
;
38 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Keys
);
40 with System
; use type System
.Address
;
41 with System
.Put_Images
;
43 package body Ada
.Containers
.Indefinite_Ordered_Maps
with
46 pragma Suppress
(All_Checks
);
48 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
49 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
50 -- See comment in Ada.Containers.Helpers
52 -----------------------------
53 -- Node Access Subprograms --
54 -----------------------------
56 -- These subprograms provide a functional interface to access fields
57 -- of a node, and a procedural interface for modifying these values.
59 function Color
(Node
: Node_Access
) return Color_Type
;
60 pragma Inline
(Color
);
62 function Left
(Node
: Node_Access
) return Node_Access
;
65 function Parent
(Node
: Node_Access
) return Node_Access
;
66 pragma Inline
(Parent
);
68 function Right
(Node
: Node_Access
) return Node_Access
;
69 pragma Inline
(Right
);
71 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
72 pragma Inline
(Set_Parent
);
74 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
75 pragma Inline
(Set_Left
);
77 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
78 pragma Inline
(Set_Right
);
80 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
81 pragma Inline
(Set_Color
);
83 -----------------------
84 -- Local Subprograms --
85 -----------------------
87 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
88 pragma Inline
(Copy_Node
);
90 procedure Free
(X
: in out Node_Access
);
92 function Is_Equal_Node_Node
93 (L
, R
: Node_Access
) return Boolean;
94 pragma Inline
(Is_Equal_Node_Node
);
96 function Is_Greater_Key_Node
98 Right
: Node_Access
) return Boolean;
99 pragma Inline
(Is_Greater_Key_Node
);
101 function Is_Less_Key_Node
103 Right
: Node_Access
) return Boolean;
104 pragma Inline
(Is_Less_Key_Node
);
106 --------------------------
107 -- Local Instantiations --
108 --------------------------
110 package Tree_Operations
is
111 new Red_Black_Trees
.Generic_Operations
(Tree_Types
);
113 procedure Delete_Tree
is
114 new Tree_Operations
.Generic_Delete_Tree
(Free
);
116 function Copy_Tree
is
117 new Tree_Operations
.Generic_Copy_Tree
(Copy_Node
, Delete_Tree
);
122 new Red_Black_Trees
.Generic_Keys
123 (Tree_Operations
=> Tree_Operations
,
124 Key_Type
=> Key_Type
,
125 Is_Less_Key_Node
=> Is_Less_Key_Node
,
126 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
128 procedure Free_Key
is
129 new Ada
.Unchecked_Deallocation
(Key_Type
, Key_Access
);
131 procedure Free_Element
is
132 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
135 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
141 function "<" (Left
, Right
: Cursor
) return Boolean is
143 if Checks
and then Left
.Node
= null then
144 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
147 if Checks
and then Right
.Node
= null then
148 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
151 if Checks
and then Left
.Node
.Key
= null then
152 raise Program_Error
with "Left cursor in ""<"" is bad";
155 if Checks
and then Right
.Node
.Key
= null then
156 raise Program_Error
with "Right cursor in ""<"" is bad";
159 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
160 "Left cursor in ""<"" is bad");
162 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
163 "Right cursor in ""<"" is bad");
165 return Left
.Node
.Key
.all < Right
.Node
.Key
.all;
168 function "<" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
170 if Checks
and then Left
.Node
= null then
171 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
174 if Checks
and then Left
.Node
.Key
= null then
175 raise Program_Error
with "Left cursor in ""<"" is bad";
178 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
179 "Left cursor in ""<"" is bad");
181 return Left
.Node
.Key
.all < Right
;
184 function "<" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
186 if Checks
and then Right
.Node
= null then
187 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
190 if Checks
and then Right
.Node
.Key
= null then
191 raise Program_Error
with "Right cursor in ""<"" is bad";
194 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
195 "Right cursor in ""<"" is bad");
197 return Left
< Right
.Node
.Key
.all;
204 function "=" (Left
, Right
: Map
) return Boolean is
206 return Is_Equal
(Left
.Tree
, Right
.Tree
);
213 function ">" (Left
, Right
: Cursor
) return Boolean is
215 if Checks
and then Left
.Node
= null then
216 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
219 if Checks
and then Right
.Node
= null then
220 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
223 if Checks
and then Left
.Node
.Key
= null then
224 raise Program_Error
with "Left cursor in ""<"" is bad";
227 if Checks
and then Right
.Node
.Key
= null then
228 raise Program_Error
with "Right cursor in ""<"" is bad";
231 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
232 "Left cursor in "">"" is bad");
234 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
235 "Right cursor in "">"" is bad");
237 return Right
.Node
.Key
.all < Left
.Node
.Key
.all;
240 function ">" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
242 if Checks
and then Left
.Node
= null then
243 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
246 if Checks
and then Left
.Node
.Key
= null then
247 raise Program_Error
with "Left cursor in ""<"" is bad";
250 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
251 "Left cursor in "">"" is bad");
253 return Right
< Left
.Node
.Key
.all;
256 function ">" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
258 if Checks
and then Right
.Node
= null then
259 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
262 if Checks
and then Right
.Node
.Key
= null then
263 raise Program_Error
with "Right cursor in ""<"" is bad";
266 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
267 "Right cursor in "">"" is bad");
269 return Right
.Node
.Key
.all < Left
;
276 procedure Adjust
is new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
278 procedure Adjust
(Container
: in out Map
) is
280 Adjust
(Container
.Tree
);
287 procedure Assign
(Target
: in out Map
; Source
: Map
) is
288 procedure Insert_Item
(Node
: Node_Access
);
289 pragma Inline
(Insert_Item
);
291 procedure Insert_Items
is
292 new Tree_Operations
.Generic_Iteration
(Insert_Item
);
298 procedure Insert_Item
(Node
: Node_Access
) is
300 Target
.Insert
(Key
=> Node
.Key
.all, New_Item
=> Node
.Element
.all);
303 -- Start of processing for Assign
306 if Target
'Address = Source
'Address then
311 Insert_Items
(Source
.Tree
);
318 function Ceiling
(Container
: Map
; Key
: Key_Type
) return Cursor
is
319 Node
: constant Node_Access
:= Key_Ops
.Ceiling
(Container
.Tree
, Key
);
321 return (if Node
= null then No_Element
322 else Cursor
'(Container'Unrestricted_Access, Node));
329 procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree);
331 procedure Clear (Container : in out Map) is
333 Clear (Container.Tree);
340 function Color (Node : Node_Access) return Color_Type is
345 ------------------------
346 -- Constant_Reference --
347 ------------------------
349 function Constant_Reference
350 (Container : aliased Map;
351 Position : Cursor) return Constant_Reference_Type
354 if Checks and then Position.Container = null then
355 raise Constraint_Error with
356 "Position cursor has no element";
359 if Checks and then Position.Container /= Container'Unrestricted_Access
361 raise Program_Error with
362 "Position cursor designates wrong map";
365 if Checks and then Position.Node.Element = null then
366 raise Program_Error with "Node has no element";
369 pragma Assert (Vet (Container.Tree, Position.Node),
370 "Position cursor in Constant_Reference is bad");
373 TC : constant Tamper_Counts_Access :=
374 Container.Tree.TC'Unrestricted_Access;
376 return R : constant Constant_Reference_Type :=
377 (Element => Position.Node.Element.all'Access,
378 Control => (Controlled with TC))
383 end Constant_Reference;
385 function Constant_Reference
386 (Container : aliased Map;
387 Key : Key_Type) return Constant_Reference_Type
389 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
392 if Checks and then Node = null then
393 raise Constraint_Error with "key not in map";
396 if Checks and then Node.Element = null then
397 raise Program_Error with "Node has no element";
401 TC : constant Tamper_Counts_Access :=
402 Container.Tree.TC'Unrestricted_Access;
404 return R : constant Constant_Reference_Type :=
405 (Element => Node.Element.all'Access,
406 Control => (Controlled with TC))
411 end Constant_Reference;
417 function Contains (Container : Map; Key : Key_Type) return Boolean is
419 return Find (Container, Key) /= No_Element;
426 function Copy (Source : Map) return Map is
428 return Target : Map do
429 Target.Assign (Source);
437 function Copy_Node (Source : Node_Access) return Node_Access is
438 K : Key_Access := new Key_Type'(Source
.Key
.all);
442 E
:= new Element_Type
'(Source.Element.all);
444 return new Node_Type'(Parent
=> null,
447 Color
=> Source
.Color
,
463 (Container
: in out Map
;
464 Position
: in out Cursor
)
467 if Checks
and then Position
.Node
= null then
468 raise Constraint_Error
with
469 "Position cursor of Delete equals No_Element";
473 (Position
.Node
.Key
= null or else Position
.Node
.Element
= null)
475 raise Program_Error
with "Position cursor of Delete is bad";
478 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
480 raise Program_Error
with
481 "Position cursor of Delete designates wrong map";
484 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
485 "Position cursor of Delete is bad");
487 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, Position
.Node
);
488 Free
(Position
.Node
);
490 Position
.Container
:= null;
493 procedure Delete
(Container
: in out Map
; Key
: Key_Type
) is
494 X
: Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
497 if Checks
and then X
= null then
498 raise Constraint_Error
with "key not in map";
501 Delete_Node_Sans_Free
(Container
.Tree
, X
);
509 procedure Delete_First
(Container
: in out Map
) is
510 X
: Node_Access
:= Container
.Tree
.First
;
513 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
522 procedure Delete_Last
(Container
: in out Map
) is
523 X
: Node_Access
:= Container
.Tree
.Last
;
526 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
535 function Element
(Position
: Cursor
) return Element_Type
is
537 if Checks
and then Position
.Node
= null then
538 raise Constraint_Error
with
539 "Position cursor of function Element equals No_Element";
542 if Checks
and then Position
.Node
.Element
= null then
543 raise Program_Error
with
544 "Position cursor of function Element is bad";
548 and then (Left
(Position
.Node
) = Position
.Node
550 Right
(Position
.Node
) = Position
.Node
)
552 raise Program_Error
with "dangling cursor";
555 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
556 "Position cursor of function Element is bad");
558 return Position
.Node
.Element
.all;
561 function Element
(Container
: Map
; Key
: Key_Type
) return Element_Type
is
562 Node
: constant Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
565 if Checks
and then Node
= null then
566 raise Constraint_Error
with "key not in map";
569 return Node
.Element
.all;
572 ---------------------
573 -- Equivalent_Keys --
574 ---------------------
576 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
578 return (if Left
< Right
or else Right
< Left
then False else True);
585 procedure Exclude
(Container
: in out Map
; Key
: Key_Type
) is
586 X
: Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
589 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
598 procedure Finalize
(Object
: in out Iterator
) is
600 if Object
.Container
/= null then
601 Unbusy
(Object
.Container
.Tree
.TC
);
609 function Find
(Container
: Map
; Key
: Key_Type
) return Cursor
is
610 Node
: constant Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
612 return (if Node
= null then No_Element
613 else Cursor
'(Container'Unrestricted_Access, Node));
620 function First (Container : Map) return Cursor is
621 T : Tree_Type renames Container.Tree;
623 return (if T.First = null then No_Element
624 else Cursor'(Container
'Unrestricted_Access, T
.First
));
627 function First
(Object
: Iterator
) return Cursor
is
629 -- The value of the iterator object's Node component influences the
630 -- behavior of the First (and Last) selector function.
632 -- When the Node component is null, this means the iterator object was
633 -- constructed without a start expression, in which case the (forward)
634 -- iteration starts from the (logical) beginning of the entire sequence
635 -- of items (corresponding to Container.First for a forward iterator).
637 -- Otherwise, this is iteration over a partial sequence of items. When
638 -- the Node component is non-null, the iterator object was constructed
639 -- with a start expression, that specifies the position from which the
640 -- (forward) partial iteration begins.
642 if Object
.Node
= null then
643 return Object
.Container
.First
;
645 return Cursor
'(Object.Container, Object.Node);
653 function First_Element (Container : Map) return Element_Type is
654 T : Tree_Type renames Container.Tree;
656 if Checks and then T.First = null then
657 raise Constraint_Error with "map is empty";
660 return T.First.Element.all;
667 function First_Key (Container : Map) return Key_Type is
668 T : Tree_Type renames Container.Tree;
670 if Checks and then T.First = null then
671 raise Constraint_Error with "map is empty";
674 return T.First.Key.all;
681 function Floor (Container : Map; Key : Key_Type) return Cursor is
682 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
684 return (if Node = null then No_Element
685 else Cursor'(Container
'Unrestricted_Access, Node
));
692 procedure Free
(X
: in out Node_Access
) is
693 procedure Deallocate
is
694 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
713 Free_Element
(X
.Element
);
724 Free_Element
(X
.Element
);
737 ------------------------
738 -- Get_Element_Access --
739 ------------------------
741 function Get_Element_Access
742 (Position
: Cursor
) return not null Element_Access
is
744 return Position
.Node
.Element
;
745 end Get_Element_Access
;
751 function Has_Element
(Position
: Cursor
) return Boolean is
753 return Position
/= No_Element
;
761 (Container
: in out Map
;
763 New_Item
: Element_Type
)
772 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
775 TE_Check
(Container
.Tree
.TC
);
777 K
:= Position
.Node
.Key
;
778 E
:= Position
.Node
.Element
;
780 Position
.Node
.Key
:= new Key_Type
'(Key);
783 -- The element allocator may need an accessibility check in the
784 -- case the actual type is class-wide or has access discriminants
785 -- (see RM 4.8(10.1) and AI12-0035).
787 pragma Unsuppress (Accessibility_Check);
790 Position.Node.Element := new Element_Type'(New_Item
);
808 (Container
: in out Map
;
810 New_Item
: Element_Type
;
811 Position
: out Cursor
;
812 Inserted
: out Boolean)
814 function New_Node
return Node_Access
;
815 pragma Inline
(New_Node
);
817 procedure Insert_Post
is
818 new Key_Ops
.Generic_Insert_Post
(New_Node
);
820 procedure Insert_Sans_Hint
is
821 new Key_Ops
.Generic_Conditional_Insert
(Insert_Post
);
827 function New_Node
return Node_Access
is
828 Node
: Node_Access
:= new Node_Type
;
830 -- The element allocator may need an accessibility check in the case
831 -- the actual type is class-wide or has access discriminants (see
832 -- RM 4.8(10.1) and AI12-0035).
834 pragma Unsuppress
(Accessibility_Check
);
837 Node
.Key
:= new Key_Type
'(Key);
838 Node.Element := new Element_Type'(New_Item
);
844 -- On exception, deallocate key and elem. Note that free
845 -- deallocates both the key and the elem.
851 -- Start of processing for Insert
860 Position
.Container
:= Container
'Unrestricted_Access;
864 (Container
: in out Map
;
866 New_Item
: Element_Type
)
872 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
874 if Checks
and then not Inserted
then
875 raise Constraint_Error
with "key already in map";
883 function Is_Empty
(Container
: Map
) return Boolean is
885 return Container
.Tree
.Length
= 0;
888 ------------------------
889 -- Is_Equal_Node_Node --
890 ------------------------
892 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean is
894 return (if L
.Key
.all < R
.Key
.all then False
895 elsif R
.Key
.all < L
.Key
.all then False
896 else L
.Element
.all = R
.Element
.all);
897 end Is_Equal_Node_Node
;
899 -------------------------
900 -- Is_Greater_Key_Node --
901 -------------------------
903 function Is_Greater_Key_Node
905 Right
: Node_Access
) return Boolean
908 -- k > node same as node < k
910 return Right
.Key
.all < Left
;
911 end Is_Greater_Key_Node
;
913 ----------------------
914 -- Is_Less_Key_Node --
915 ----------------------
917 function Is_Less_Key_Node
919 Right
: Node_Access
) return Boolean is
921 return Left
< Right
.Key
.all;
922 end Is_Less_Key_Node
;
930 Process
: not null access procedure (Position
: Cursor
))
932 procedure Process_Node
(Node
: Node_Access
);
933 pragma Inline
(Process_Node
);
935 procedure Local_Iterate
is
936 new Tree_Operations
.Generic_Iteration
(Process_Node
);
942 procedure Process_Node
(Node
: Node_Access
) is
944 Process
(Cursor
'(Container'Unrestricted_Access, Node));
947 Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
949 -- Start of processing for Iterate
952 Local_Iterate (Container.Tree);
956 (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
959 -- The value of the Node component influences the behavior of the First
960 -- and Last selector functions of the iterator object. When the Node
961 -- component is null (as is the case here), this means the iterator
962 -- object was constructed without a start expression. This is a complete
963 -- iterator, meaning that the iteration starts from the (logical)
964 -- beginning of the sequence of items.
966 -- Note: For a forward iterator, Container.First is the beginning, and
967 -- for a reverse iterator, Container.Last is the beginning.
969 return It : constant Iterator :=
970 (Limited_Controlled with
971 Container => Container'Unrestricted_Access,
974 Busy (Container.Tree.TC'Unrestricted_Access.all);
981 return Map_Iterator_Interfaces.Reversible_Iterator'Class
984 -- It was formerly the case that when Start = No_Element, the partial
985 -- iterator was defined to behave the same as for a complete iterator,
986 -- and iterate over the entire sequence of items. However, those
987 -- semantics were unintuitive and arguably error-prone (it is too easy
988 -- to accidentally create an endless loop), and so they were changed,
989 -- per the ARG meeting in Denver on 2011/11. However, there was no
990 -- consensus about what positive meaning this corner case should have,
991 -- and so it was decided to simply raise an exception. This does imply,
992 -- however, that it is not possible to use a partial iterator to specify
993 -- an empty sequence of items.
995 if Checks and then Start = No_Element then
996 raise Constraint_Error with
997 "Start position for iterator equals No_Element";
1000 if Checks and then Start.Container /= Container'Unrestricted_Access then
1001 raise Program_Error with
1002 "Start cursor of Iterate designates wrong map";
1005 pragma Assert (Vet (Container.Tree, Start.Node),
1006 "Start cursor of Iterate is bad");
1008 -- The value of the Node component influences the behavior of the First
1009 -- and Last selector functions of the iterator object. When the Node
1010 -- component is non-null (as is the case here), it means that this
1011 -- is a partial iteration, over a subset of the complete sequence of
1012 -- items. The iterator object was constructed with a start expression,
1013 -- indicating the position from which the iteration begins. Note that
1014 -- the start position has the same value irrespective of whether this
1015 -- is a forward or reverse iteration.
1017 return It : constant Iterator :=
1018 (Limited_Controlled with
1019 Container => Container'Unrestricted_Access,
1022 Busy (Container.Tree.TC'Unrestricted_Access.all);
1030 function Key (Position : Cursor) return Key_Type is
1032 if Checks and then Position.Node = null then
1033 raise Constraint_Error with
1034 "Position cursor of function Key equals No_Element";
1037 if Checks and then Position.Node.Key = null then
1038 raise Program_Error with
1039 "Position cursor of function Key is bad";
1042 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1043 "Position cursor of function Key is bad");
1045 return Position.Node.Key.all;
1052 function Last (Container : Map) return Cursor is
1053 T : Tree_Type renames Container.Tree;
1055 return (if T.Last = null then No_Element
1056 else Cursor'(Container
'Unrestricted_Access, T
.Last
));
1059 function Last
(Object
: Iterator
) return Cursor
is
1061 -- The value of the iterator object's Node component influences the
1062 -- behavior of the Last (and First) selector function.
1064 -- When the Node component is null, this means the iterator object was
1065 -- constructed without a start expression, in which case the (reverse)
1066 -- iteration starts from the (logical) beginning of the entire sequence
1067 -- (corresponding to Container.Last, for a reverse iterator).
1069 -- Otherwise, this is iteration over a partial sequence of items. When
1070 -- the Node component is non-null, the iterator object was constructed
1071 -- with a start expression, that specifies the position from which the
1072 -- (reverse) partial iteration begins.
1074 if Object
.Node
= null then
1075 return Object
.Container
.Last
;
1077 return Cursor
'(Object.Container, Object.Node);
1085 function Last_Element (Container : Map) return Element_Type is
1086 T : Tree_Type renames Container.Tree;
1089 if Checks and then T.Last = null then
1090 raise Constraint_Error with "map is empty";
1093 return T.Last.Element.all;
1100 function Last_Key (Container : Map) return Key_Type is
1101 T : Tree_Type renames Container.Tree;
1104 if Checks and then T.Last = null then
1105 raise Constraint_Error with "map is empty";
1108 return T.Last.Key.all;
1115 function Left (Node : Node_Access) return Node_Access is
1124 function Length (Container : Map) return Count_Type is
1126 return Container.Tree.Length;
1133 procedure Move is new Tree_Operations.Generic_Move (Clear);
1135 procedure Move (Target : in out Map; Source : in out Map) is
1137 Move (Target => Target.Tree, Source => Source.Tree);
1144 function Next (Position : Cursor) return Cursor is
1146 if Position = No_Element then
1150 pragma Assert (Position.Node /= null);
1151 pragma Assert (Position.Node.Key /= null);
1152 pragma Assert (Position.Node.Element /= null);
1153 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1154 "Position cursor of Next is bad");
1157 Node : constant Node_Access :=
1158 Tree_Operations.Next (Position.Node);
1160 return (if Node = null then No_Element
1161 else Cursor'(Position
.Container
, Node
));
1165 procedure Next
(Position
: in out Cursor
) is
1167 Position
:= Next
(Position
);
1172 Position
: Cursor
) return Cursor
1175 if Position
.Container
= null then
1179 if Checks
and then Position
.Container
/= Object
.Container
then
1180 raise Program_Error
with
1181 "Position cursor of Next designates wrong map";
1184 return Next
(Position
);
1191 function Parent
(Node
: Node_Access
) return Node_Access
is
1200 function Previous
(Position
: Cursor
) return Cursor
is
1202 if Position
= No_Element
then
1206 pragma Assert
(Position
.Node
/= null);
1207 pragma Assert
(Position
.Node
.Key
/= null);
1208 pragma Assert
(Position
.Node
.Element
/= null);
1209 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1210 "Position cursor of Previous is bad");
1213 Node
: constant Node_Access
:=
1214 Tree_Operations
.Previous
(Position
.Node
);
1216 return (if Node
= null then No_Element
1217 else Cursor
'(Position.Container, Node));
1221 procedure Previous (Position : in out Cursor) is
1223 Position := Previous (Position);
1228 Position : Cursor) return Cursor
1231 if Position.Container = null then
1235 if Checks and then Position.Container /= Object.Container then
1236 raise Program_Error with
1237 "Position cursor of Previous designates wrong map";
1240 return Previous (Position);
1243 ----------------------
1244 -- Pseudo_Reference --
1245 ----------------------
1247 function Pseudo_Reference
1248 (Container : aliased Map'Class) return Reference_Control_Type
1250 TC : constant Tamper_Counts_Access :=
1251 Container.Tree.TC'Unrestricted_Access;
1253 return R : constant Reference_Control_Type := (Controlled with TC) do
1256 end Pseudo_Reference;
1262 procedure Query_Element
1264 Process : not null access procedure (Key : Key_Type;
1265 Element : Element_Type))
1268 if Checks and then Position.Node = null then
1269 raise Constraint_Error with
1270 "Position cursor of Query_Element equals No_Element";
1274 (Position.Node.Key = null or else Position.Node.Element = null)
1276 raise Program_Error with
1277 "Position cursor of Query_Element is bad";
1280 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1281 "Position cursor of Query_Element is bad");
1284 T : Tree_Type renames Position.Container.Tree;
1285 Lock : With_Lock (T.TC'Unrestricted_Access);
1286 K : Key_Type renames Position.Node.Key.all;
1287 E : Element_Type renames Position.Node.Element.all;
1298 (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
1300 First_Time : Boolean := True;
1301 use System.Put_Images;
1303 procedure Put_Key_Value (Position : Cursor);
1304 procedure Put_Key_Value (Position : Cursor) is
1307 First_Time := False;
1309 Simple_Array_Between (S);
1312 Key_Type'Put_Image (S, Key (Position));
1314 Element_Type'Put_Image (S, Element (Position));
1319 Iterate (V, Put_Key_Value'Access);
1328 (Stream : not null access Root_Stream_Type'Class;
1329 Container : out Map)
1332 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1333 pragma Inline (Read_Node);
1336 new Tree_Operations.Generic_Read (Clear, Read_Node);
1343 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1345 Node : Node_Access := new Node_Type;
1347 Node.Key := new Key_Type'(Key_Type
'Input (Stream
));
1348 Node
.Element
:= new Element_Type
'(Element_Type'Input (Stream));
1352 Free (Node); -- Note that Free deallocates key and elem too
1356 -- Start of processing for Read
1359 Read (Stream, Container.Tree);
1363 (Stream : not null access Root_Stream_Type'Class;
1367 raise Program_Error with "attempt to stream map cursor";
1371 (Stream : not null access Root_Stream_Type'Class;
1372 Item : out Reference_Type)
1375 raise Program_Error with "attempt to stream reference";
1379 (Stream : not null access Root_Stream_Type'Class;
1380 Item : out Constant_Reference_Type)
1383 raise Program_Error with "attempt to stream reference";
1391 (Container : aliased in out Map;
1392 Position : Cursor) return Reference_Type
1395 if Checks and then Position.Container = null then
1396 raise Constraint_Error with
1397 "Position cursor has no element";
1400 if Checks and then Position.Container /= Container'Unrestricted_Access
1402 raise Program_Error with
1403 "Position cursor designates wrong map";
1406 if Checks and then Position.Node.Element = null then
1407 raise Program_Error with "Node has no element";
1410 pragma Assert (Vet (Container.Tree, Position.Node),
1411 "Position cursor in function Reference is bad");
1414 TC : constant Tamper_Counts_Access :=
1415 Container.Tree.TC'Unrestricted_Access;
1417 return R : constant Reference_Type :=
1418 (Element => Position.Node.Element.all'Access,
1419 Control => (Controlled with TC))
1427 (Container : aliased in out Map;
1428 Key : Key_Type) return Reference_Type
1430 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1433 if Checks and then Node = null then
1434 raise Constraint_Error with "key not in map";
1437 if Checks and then Node.Element = null then
1438 raise Program_Error with "Node has no element";
1442 TC : constant Tamper_Counts_Access :=
1443 Container.Tree.TC'Unrestricted_Access;
1445 return R : constant Reference_Type :=
1446 (Element => Node.Element.all'Access,
1447 Control => (Controlled with TC))
1459 (Container : in out Map;
1461 New_Item : Element_Type)
1463 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1469 TE_Check (Container.Tree.TC);
1471 if Checks and then Node = null then
1472 raise Constraint_Error with "key not in map";
1478 Node.Key := new Key_Type'(Key
);
1481 -- The element allocator may need an accessibility check in the case
1482 -- the actual type is class-wide or has access discriminants (see
1483 -- RM 4.8(10.1) and AI12-0035).
1485 pragma Unsuppress
(Accessibility_Check
);
1488 Node
.Element
:= new Element_Type
'(New_Item);
1500 ---------------------
1501 -- Replace_Element --
1502 ---------------------
1504 procedure Replace_Element
1505 (Container : in out Map;
1507 New_Item : Element_Type)
1510 TE_Check (Container.Tree.TC);
1512 if Checks and then Position.Node = null then
1513 raise Constraint_Error with
1514 "Position cursor of Replace_Element equals No_Element";
1518 (Position.Node.Key = null or else Position.Node.Element = null)
1520 raise Program_Error with
1521 "Position cursor of Replace_Element is bad";
1524 if Checks and then Position.Container /= Container'Unrestricted_Access
1526 raise Program_Error with
1527 "Position cursor of Replace_Element designates wrong map";
1530 pragma Assert (Vet (Container.Tree, Position.Node),
1531 "Position cursor of Replace_Element is bad");
1534 X : Element_Access := Position.Node.Element;
1536 -- The element allocator may need an accessibility check in the case
1537 -- the actual type is class-wide or has access discriminants (see
1538 -- RM 4.8(10.1) and AI12-0035).
1540 pragma Unsuppress (Accessibility_Check);
1543 Position.Node.Element := new Element_Type'(New_Item
);
1546 end Replace_Element
;
1548 ---------------------
1549 -- Reverse_Iterate --
1550 ---------------------
1552 procedure Reverse_Iterate
1554 Process
: not null access procedure (Position
: Cursor
))
1556 procedure Process_Node
(Node
: Node_Access
);
1557 pragma Inline
(Process_Node
);
1559 procedure Local_Reverse_Iterate
is
1560 new Tree_Operations
.Generic_Reverse_Iteration
(Process_Node
);
1566 procedure Process_Node
(Node
: Node_Access
) is
1568 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1571 Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
1573 -- Start of processing for Reverse_Iterate
1576 Local_Reverse_Iterate (Container.Tree);
1577 end Reverse_Iterate;
1583 function Right (Node : Node_Access) return Node_Access is
1592 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1594 Node.Color := Color;
1601 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1610 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1612 Node.Parent := Parent;
1619 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1621 Node.Right := Right;
1624 --------------------
1625 -- Update_Element --
1626 --------------------
1628 procedure Update_Element
1629 (Container : in out Map;
1631 Process : not null access procedure (Key : Key_Type;
1632 Element : in out Element_Type))
1635 if Checks and then Position.Node = null then
1636 raise Constraint_Error with
1637 "Position cursor of Update_Element equals No_Element";
1641 (Position.Node.Key = null or else Position.Node.Element = null)
1643 raise Program_Error with
1644 "Position cursor of Update_Element is bad";
1647 if Checks and then Position.Container /= Container'Unrestricted_Access
1649 raise Program_Error with
1650 "Position cursor of Update_Element designates wrong map";
1653 pragma Assert (Vet (Container.Tree, Position.Node),
1654 "Position cursor of Update_Element is bad");
1657 T : Tree_Type renames Position.Container.Tree;
1658 Lock : With_Lock (T.TC'Unrestricted_Access);
1659 K : Key_Type renames Position.Node.Key.all;
1660 E : Element_Type renames Position.Node.Element.all;
1671 (Stream : not null access Root_Stream_Type'Class;
1674 procedure Write_Node
1675 (Stream : not null access Root_Stream_Type'Class;
1676 Node : Node_Access);
1677 pragma Inline (Write_Node);
1680 new Tree_Operations.Generic_Write (Write_Node);
1686 procedure Write_Node
1687 (Stream : not null access Root_Stream_Type'Class;
1691 Key_Type'Output (Stream, Node.Key.all);
1692 Element_Type'Output (Stream, Node.Element.all);
1695 -- Start of processing for Write
1698 Write (Stream, Container.Tree);
1702 (Stream : not null access Root_Stream_Type'Class;
1706 raise Program_Error with "attempt to stream map cursor";
1710 (Stream : not null access Root_Stream_Type'Class;
1711 Item : Reference_Type)
1714 raise Program_Error with "attempt to stream reference";
1718 (Stream : not null access Root_Stream_Type'Class;
1719 Item : Constant_Reference_Type)
1722 raise Program_Error with "attempt to stream reference";
1725 end Ada.Containers.Indefinite_Ordered_Maps;