1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
9 -- Copyright (C) 2004-2018, 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
;
42 package body Ada
.Containers
.Indefinite_Ordered_Maps
is
43 pragma Suppress
(All_Checks
);
45 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
46 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
47 -- See comment in Ada.Containers.Helpers
49 -----------------------------
50 -- Node Access Subprograms --
51 -----------------------------
53 -- These subprograms provide a functional interface to access fields
54 -- of a node, and a procedural interface for modifying these values.
56 function Color
(Node
: Node_Access
) return Color_Type
;
57 pragma Inline
(Color
);
59 function Left
(Node
: Node_Access
) return Node_Access
;
62 function Parent
(Node
: Node_Access
) return Node_Access
;
63 pragma Inline
(Parent
);
65 function Right
(Node
: Node_Access
) return Node_Access
;
66 pragma Inline
(Right
);
68 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
69 pragma Inline
(Set_Parent
);
71 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
72 pragma Inline
(Set_Left
);
74 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
75 pragma Inline
(Set_Right
);
77 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
78 pragma Inline
(Set_Color
);
80 -----------------------
81 -- Local Subprograms --
82 -----------------------
84 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
85 pragma Inline
(Copy_Node
);
87 procedure Free
(X
: in out Node_Access
);
89 function Is_Equal_Node_Node
90 (L
, R
: Node_Access
) return Boolean;
91 pragma Inline
(Is_Equal_Node_Node
);
93 function Is_Greater_Key_Node
95 Right
: Node_Access
) return Boolean;
96 pragma Inline
(Is_Greater_Key_Node
);
98 function Is_Less_Key_Node
100 Right
: Node_Access
) return Boolean;
101 pragma Inline
(Is_Less_Key_Node
);
103 --------------------------
104 -- Local Instantiations --
105 --------------------------
107 package Tree_Operations
is
108 new Red_Black_Trees
.Generic_Operations
(Tree_Types
);
110 procedure Delete_Tree
is
111 new Tree_Operations
.Generic_Delete_Tree
(Free
);
113 function Copy_Tree
is
114 new Tree_Operations
.Generic_Copy_Tree
(Copy_Node
, Delete_Tree
);
119 new Red_Black_Trees
.Generic_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
);
125 procedure Free_Key
is
126 new Ada
.Unchecked_Deallocation
(Key_Type
, Key_Access
);
128 procedure Free_Element
is
129 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
132 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
138 function "<" (Left
, Right
: Cursor
) return Boolean is
140 if Checks
and then Left
.Node
= null then
141 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
144 if Checks
and then Right
.Node
= null then
145 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
148 if Checks
and then Left
.Node
.Key
= null then
149 raise Program_Error
with "Left cursor in ""<"" is bad";
152 if Checks
and then Right
.Node
.Key
= null then
153 raise Program_Error
with "Right cursor in ""<"" is bad";
156 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
157 "Left cursor in ""<"" is bad");
159 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
160 "Right cursor in ""<"" is bad");
162 return Left
.Node
.Key
.all < Right
.Node
.Key
.all;
165 function "<" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
167 if Checks
and then Left
.Node
= null then
168 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
171 if Checks
and then Left
.Node
.Key
= null then
172 raise Program_Error
with "Left cursor in ""<"" is bad";
175 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
176 "Left cursor in ""<"" is bad");
178 return Left
.Node
.Key
.all < Right
;
181 function "<" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
183 if Checks
and then Right
.Node
= null then
184 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
187 if Checks
and then Right
.Node
.Key
= null then
188 raise Program_Error
with "Right cursor in ""<"" is bad";
191 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
192 "Right cursor in ""<"" is bad");
194 return Left
< Right
.Node
.Key
.all;
201 function "=" (Left
, Right
: Map
) return Boolean is
203 return Is_Equal
(Left
.Tree
, Right
.Tree
);
210 function ">" (Left
, Right
: Cursor
) return Boolean is
212 if Checks
and then Left
.Node
= null then
213 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
216 if Checks
and then Right
.Node
= null then
217 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
220 if Checks
and then Left
.Node
.Key
= null then
221 raise Program_Error
with "Left cursor in ""<"" is bad";
224 if Checks
and then Right
.Node
.Key
= null then
225 raise Program_Error
with "Right cursor in ""<"" is bad";
228 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
229 "Left cursor in "">"" is bad");
231 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
232 "Right cursor in "">"" is bad");
234 return Right
.Node
.Key
.all < Left
.Node
.Key
.all;
237 function ">" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
239 if Checks
and then Left
.Node
= null then
240 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
243 if Checks
and then Left
.Node
.Key
= null then
244 raise Program_Error
with "Left cursor in ""<"" is bad";
247 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
248 "Left cursor in "">"" is bad");
250 return Right
< Left
.Node
.Key
.all;
253 function ">" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
255 if Checks
and then Right
.Node
= null then
256 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
259 if Checks
and then Right
.Node
.Key
= null then
260 raise Program_Error
with "Right cursor in ""<"" is bad";
263 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
264 "Right cursor in "">"" is bad");
266 return Right
.Node
.Key
.all < Left
;
273 procedure Adjust
is new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
275 procedure Adjust
(Container
: in out Map
) is
277 Adjust
(Container
.Tree
);
284 procedure Assign
(Target
: in out Map
; Source
: Map
) is
285 procedure Insert_Item
(Node
: Node_Access
);
286 pragma Inline
(Insert_Item
);
288 procedure Insert_Items
is
289 new Tree_Operations
.Generic_Iteration
(Insert_Item
);
295 procedure Insert_Item
(Node
: Node_Access
) is
297 Target
.Insert
(Key
=> Node
.Key
.all, New_Item
=> Node
.Element
.all);
300 -- Start of processing for Assign
303 if Target
'Address = Source
'Address then
308 Insert_Items
(Source
.Tree
);
315 function Ceiling
(Container
: Map
; Key
: Key_Type
) return Cursor
is
316 Node
: constant Node_Access
:= Key_Ops
.Ceiling
(Container
.Tree
, Key
);
318 return (if Node
= null then No_Element
319 else Cursor
'(Container'Unrestricted_Access, Node));
326 procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree);
328 procedure Clear (Container : in out Map) is
330 Clear (Container.Tree);
337 function Color (Node : Node_Access) return Color_Type is
342 ------------------------
343 -- Constant_Reference --
344 ------------------------
346 function Constant_Reference
347 (Container : aliased Map;
348 Position : Cursor) return Constant_Reference_Type
351 if Checks and then Position.Container = null then
352 raise Constraint_Error with
353 "Position cursor has no element";
356 if Checks and then Position.Container /= Container'Unrestricted_Access
358 raise Program_Error with
359 "Position cursor designates wrong map";
362 if Checks and then Position.Node.Element = null then
363 raise Program_Error with "Node has no element";
366 pragma Assert (Vet (Container.Tree, Position.Node),
367 "Position cursor in Constant_Reference is bad");
370 TC : constant Tamper_Counts_Access :=
371 Container.Tree.TC'Unrestricted_Access;
373 return R : constant Constant_Reference_Type :=
374 (Element => Position.Node.Element.all'Access,
375 Control => (Controlled with TC))
380 end Constant_Reference;
382 function Constant_Reference
383 (Container : aliased Map;
384 Key : Key_Type) return Constant_Reference_Type
386 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
389 if Checks and then Node = null then
390 raise Constraint_Error with "key not in map";
393 if Checks and then Node.Element = null then
394 raise Program_Error with "Node has no element";
398 TC : constant Tamper_Counts_Access :=
399 Container.Tree.TC'Unrestricted_Access;
401 return R : constant Constant_Reference_Type :=
402 (Element => Node.Element.all'Access,
403 Control => (Controlled with TC))
408 end Constant_Reference;
414 function Contains (Container : Map; Key : Key_Type) return Boolean is
416 return Find (Container, Key) /= No_Element;
423 function Copy (Source : Map) return Map is
425 return Target : Map do
426 Target.Assign (Source);
434 function Copy_Node (Source : Node_Access) return Node_Access is
435 K : Key_Access := new Key_Type'(Source
.Key
.all);
439 E
:= new Element_Type
'(Source.Element.all);
441 return new Node_Type'(Parent
=> null,
444 Color
=> Source
.Color
,
460 (Container
: in out Map
;
461 Position
: in out Cursor
)
464 if Checks
and then Position
.Node
= null then
465 raise Constraint_Error
with
466 "Position cursor of Delete equals No_Element";
470 (Position
.Node
.Key
= null or else Position
.Node
.Element
= null)
472 raise Program_Error
with "Position cursor of Delete is bad";
475 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
477 raise Program_Error
with
478 "Position cursor of Delete designates wrong map";
481 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
482 "Position cursor of Delete is bad");
484 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, Position
.Node
);
485 Free
(Position
.Node
);
487 Position
.Container
:= null;
490 procedure Delete
(Container
: in out Map
; Key
: Key_Type
) is
491 X
: Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
494 if Checks
and then X
= null then
495 raise Constraint_Error
with "key not in map";
498 Delete_Node_Sans_Free
(Container
.Tree
, X
);
506 procedure Delete_First
(Container
: in out Map
) is
507 X
: Node_Access
:= Container
.Tree
.First
;
510 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
519 procedure Delete_Last
(Container
: in out Map
) is
520 X
: Node_Access
:= Container
.Tree
.Last
;
523 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
532 function Element
(Position
: Cursor
) return Element_Type
is
534 if Checks
and then Position
.Node
= null then
535 raise Constraint_Error
with
536 "Position cursor of function Element equals No_Element";
539 if Checks
and then Position
.Node
.Element
= null then
540 raise Program_Error
with
541 "Position cursor of function Element is bad";
545 (Left
(Position
.Node
) = Position
.Node
546 or else Right
(Position
.Node
) = Position
.Node
)
548 raise Program_Error
with "dangling cursor";
551 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
552 "Position cursor of function Element is bad");
554 return Position
.Node
.Element
.all;
557 function Element
(Container
: Map
; Key
: Key_Type
) return Element_Type
is
558 Node
: constant Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
561 if Checks
and then Node
= null then
562 raise Constraint_Error
with "key not in map";
565 return Node
.Element
.all;
568 ---------------------
569 -- Equivalent_Keys --
570 ---------------------
572 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
574 return (if Left
< Right
or else Right
< Left
then False else True);
581 procedure Exclude
(Container
: in out Map
; Key
: Key_Type
) is
582 X
: Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
585 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
594 procedure Finalize
(Object
: in out Iterator
) is
596 if Object
.Container
/= null then
597 Unbusy
(Object
.Container
.Tree
.TC
);
605 function Find
(Container
: Map
; Key
: Key_Type
) return Cursor
is
606 Node
: constant Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
608 return (if Node
= null then No_Element
609 else Cursor
'(Container'Unrestricted_Access, Node));
616 function First (Container : Map) return Cursor is
617 T : Tree_Type renames Container.Tree;
619 return (if T.First = null then No_Element
620 else Cursor'(Container
'Unrestricted_Access, T
.First
));
623 function First
(Object
: Iterator
) return Cursor
is
625 -- The value of the iterator object's Node component influences the
626 -- behavior of the First (and Last) selector function.
628 -- When the Node component is null, this means the iterator object was
629 -- constructed without a start expression, in which case the (forward)
630 -- iteration starts from the (logical) beginning of the entire sequence
631 -- of items (corresponding to Container.First for a forward iterator).
633 -- Otherwise, this is iteration over a partial sequence of items. When
634 -- the Node component is non-null, the iterator object was constructed
635 -- with a start expression, that specifies the position from which the
636 -- (forward) partial iteration begins.
638 if Object
.Node
= null then
639 return Object
.Container
.First
;
641 return Cursor
'(Object.Container, Object.Node);
649 function First_Element (Container : Map) return Element_Type is
650 T : Tree_Type renames Container.Tree;
652 if Checks and then T.First = null then
653 raise Constraint_Error with "map is empty";
656 return T.First.Element.all;
663 function First_Key (Container : Map) return Key_Type is
664 T : Tree_Type renames Container.Tree;
666 if Checks and then T.First = null then
667 raise Constraint_Error with "map is empty";
670 return T.First.Key.all;
677 function Floor (Container : Map; Key : Key_Type) return Cursor is
678 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
680 return (if Node = null then No_Element
681 else Cursor'(Container
'Unrestricted_Access, Node
));
688 procedure Free
(X
: in out Node_Access
) is
689 procedure Deallocate
is
690 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
709 Free_Element
(X
.Element
);
720 Free_Element
(X
.Element
);
733 ------------------------
734 -- Get_Element_Access --
735 ------------------------
737 function Get_Element_Access
738 (Position
: Cursor
) return not null Element_Access
is
740 return Position
.Node
.Element
;
741 end Get_Element_Access
;
747 function Has_Element
(Position
: Cursor
) return Boolean is
749 return Position
/= No_Element
;
757 (Container
: in out Map
;
759 New_Item
: Element_Type
)
768 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
771 TE_Check
(Container
.Tree
.TC
);
773 K
:= Position
.Node
.Key
;
774 E
:= Position
.Node
.Element
;
776 Position
.Node
.Key
:= new Key_Type
'(Key);
779 -- The element allocator may need an accessibility check in the
780 -- case the actual type is class-wide or has access discriminants
781 -- (see RM 4.8(10.1) and AI12-0035).
783 pragma Unsuppress (Accessibility_Check);
786 Position.Node.Element := new Element_Type'(New_Item
);
804 (Container
: in out Map
;
806 New_Item
: Element_Type
;
807 Position
: out Cursor
;
808 Inserted
: out Boolean)
810 function New_Node
return Node_Access
;
811 pragma Inline
(New_Node
);
813 procedure Insert_Post
is
814 new Key_Ops
.Generic_Insert_Post
(New_Node
);
816 procedure Insert_Sans_Hint
is
817 new Key_Ops
.Generic_Conditional_Insert
(Insert_Post
);
823 function New_Node
return Node_Access
is
824 Node
: Node_Access
:= new Node_Type
;
826 -- The element allocator may need an accessibility check in the case
827 -- the actual type is class-wide or has access discriminants (see
828 -- RM 4.8(10.1) and AI12-0035).
830 pragma Unsuppress
(Accessibility_Check
);
833 Node
.Key
:= new Key_Type
'(Key);
834 Node.Element := new Element_Type'(New_Item
);
840 -- On exception, deallocate key and elem. Note that free
841 -- deallocates both the key and the elem.
847 -- Start of processing for Insert
856 Position
.Container
:= Container
'Unrestricted_Access;
860 (Container
: in out Map
;
862 New_Item
: Element_Type
)
865 pragma Unreferenced
(Position
);
870 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
872 if Checks
and then not Inserted
then
873 raise Constraint_Error
with "key already in map";
881 function Is_Empty
(Container
: Map
) return Boolean is
883 return Container
.Tree
.Length
= 0;
886 ------------------------
887 -- Is_Equal_Node_Node --
888 ------------------------
890 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean is
892 return (if L
.Key
.all < R
.Key
.all then False
893 elsif R
.Key
.all < L
.Key
.all then False
894 else L
.Element
.all = R
.Element
.all);
895 end Is_Equal_Node_Node
;
897 -------------------------
898 -- Is_Greater_Key_Node --
899 -------------------------
901 function Is_Greater_Key_Node
903 Right
: Node_Access
) return Boolean
906 -- k > node same as node < k
908 return Right
.Key
.all < Left
;
909 end Is_Greater_Key_Node
;
911 ----------------------
912 -- Is_Less_Key_Node --
913 ----------------------
915 function Is_Less_Key_Node
917 Right
: Node_Access
) return Boolean is
919 return Left
< Right
.Key
.all;
920 end Is_Less_Key_Node
;
928 Process
: not null access procedure (Position
: Cursor
))
930 procedure Process_Node
(Node
: Node_Access
);
931 pragma Inline
(Process_Node
);
933 procedure Local_Iterate
is
934 new Tree_Operations
.Generic_Iteration
(Process_Node
);
940 procedure Process_Node
(Node
: Node_Access
) is
942 Process
(Cursor
'(Container'Unrestricted_Access, Node));
945 Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
947 -- Start of processing for Iterate
950 Local_Iterate (Container.Tree);
954 (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
957 -- The value of the Node component influences the behavior of the First
958 -- and Last selector functions of the iterator object. When the Node
959 -- component is null (as is the case here), this means the iterator
960 -- object was constructed without a start expression. This is a complete
961 -- iterator, meaning that the iteration starts from the (logical)
962 -- beginning of the sequence of items.
964 -- Note: For a forward iterator, Container.First is the beginning, and
965 -- for a reverse iterator, Container.Last is the beginning.
967 return It : constant Iterator :=
968 (Limited_Controlled with
969 Container => Container'Unrestricted_Access,
972 Busy (Container.Tree.TC'Unrestricted_Access.all);
979 return Map_Iterator_Interfaces.Reversible_Iterator'Class
982 -- It was formerly the case that when Start = No_Element, the partial
983 -- iterator was defined to behave the same as for a complete iterator,
984 -- and iterate over the entire sequence of items. However, those
985 -- semantics were unintuitive and arguably error-prone (it is too easy
986 -- to accidentally create an endless loop), and so they were changed,
987 -- per the ARG meeting in Denver on 2011/11. However, there was no
988 -- consensus about what positive meaning this corner case should have,
989 -- and so it was decided to simply raise an exception. This does imply,
990 -- however, that it is not possible to use a partial iterator to specify
991 -- an empty sequence of items.
993 if Checks and then Start = No_Element then
994 raise Constraint_Error with
995 "Start position for iterator equals No_Element";
998 if Checks and then Start.Container /= Container'Unrestricted_Access then
999 raise Program_Error with
1000 "Start cursor of Iterate designates wrong map";
1003 pragma Assert (Vet (Container.Tree, Start.Node),
1004 "Start cursor of Iterate is bad");
1006 -- The value of the Node component influences the behavior of the First
1007 -- and Last selector functions of the iterator object. When the Node
1008 -- component is non-null (as is the case here), it means that this
1009 -- is a partial iteration, over a subset of the complete sequence of
1010 -- items. The iterator object was constructed with a start expression,
1011 -- indicating the position from which the iteration begins. Note that
1012 -- the start position has the same value irrespective of whether this
1013 -- is a forward or reverse iteration.
1015 return It : constant Iterator :=
1016 (Limited_Controlled with
1017 Container => Container'Unrestricted_Access,
1020 Busy (Container.Tree.TC'Unrestricted_Access.all);
1028 function Key (Position : Cursor) return Key_Type is
1030 if Checks and then Position.Node = null then
1031 raise Constraint_Error with
1032 "Position cursor of function Key equals No_Element";
1035 if Checks and then Position.Node.Key = null then
1036 raise Program_Error with
1037 "Position cursor of function Key is bad";
1040 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1041 "Position cursor of function Key is bad");
1043 return Position.Node.Key.all;
1050 function Last (Container : Map) return Cursor is
1051 T : Tree_Type renames Container.Tree;
1053 return (if T.Last = null then No_Element
1054 else Cursor'(Container
'Unrestricted_Access, T
.Last
));
1057 function Last
(Object
: Iterator
) return Cursor
is
1059 -- The value of the iterator object's Node component influences the
1060 -- behavior of the Last (and First) selector function.
1062 -- When the Node component is null, this means the iterator object was
1063 -- constructed without a start expression, in which case the (reverse)
1064 -- iteration starts from the (logical) beginning of the entire sequence
1065 -- (corresponding to Container.Last, for a reverse iterator).
1067 -- Otherwise, this is iteration over a partial sequence of items. When
1068 -- the Node component is non-null, the iterator object was constructed
1069 -- with a start expression, that specifies the position from which the
1070 -- (reverse) partial iteration begins.
1072 if Object
.Node
= null then
1073 return Object
.Container
.Last
;
1075 return Cursor
'(Object.Container, Object.Node);
1083 function Last_Element (Container : Map) return Element_Type is
1084 T : Tree_Type renames Container.Tree;
1087 if Checks and then T.Last = null then
1088 raise Constraint_Error with "map is empty";
1091 return T.Last.Element.all;
1098 function Last_Key (Container : Map) return Key_Type is
1099 T : Tree_Type renames Container.Tree;
1102 if Checks and then T.Last = null then
1103 raise Constraint_Error with "map is empty";
1106 return T.Last.Key.all;
1113 function Left (Node : Node_Access) return Node_Access is
1122 function Length (Container : Map) return Count_Type is
1124 return Container.Tree.Length;
1131 procedure Move is new Tree_Operations.Generic_Move (Clear);
1133 procedure Move (Target : in out Map; Source : in out Map) is
1135 Move (Target => Target.Tree, Source => Source.Tree);
1142 function Next (Position : Cursor) return Cursor is
1144 if Position = No_Element then
1148 pragma Assert (Position.Node /= null);
1149 pragma Assert (Position.Node.Key /= null);
1150 pragma Assert (Position.Node.Element /= null);
1151 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1152 "Position cursor of Next is bad");
1155 Node : constant Node_Access :=
1156 Tree_Operations.Next (Position.Node);
1158 return (if Node = null then No_Element
1159 else Cursor'(Position
.Container
, Node
));
1163 procedure Next
(Position
: in out Cursor
) is
1165 Position
:= Next
(Position
);
1170 Position
: Cursor
) return Cursor
1173 if Position
.Container
= null then
1177 if Checks
and then Position
.Container
/= Object
.Container
then
1178 raise Program_Error
with
1179 "Position cursor of Next designates wrong map";
1182 return Next
(Position
);
1189 function Parent
(Node
: Node_Access
) return Node_Access
is
1198 function Previous
(Position
: Cursor
) return Cursor
is
1200 if Position
= No_Element
then
1204 pragma Assert
(Position
.Node
/= null);
1205 pragma Assert
(Position
.Node
.Key
/= null);
1206 pragma Assert
(Position
.Node
.Element
/= null);
1207 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
1208 "Position cursor of Previous is bad");
1211 Node
: constant Node_Access
:=
1212 Tree_Operations
.Previous
(Position
.Node
);
1214 return (if Node
= null then No_Element
1215 else Cursor
'(Position.Container, Node));
1219 procedure Previous (Position : in out Cursor) is
1221 Position := Previous (Position);
1226 Position : Cursor) return Cursor
1229 if Position.Container = null then
1233 if Checks and then Position.Container /= Object.Container then
1234 raise Program_Error with
1235 "Position cursor of Previous designates wrong map";
1238 return Previous (Position);
1241 ----------------------
1242 -- Pseudo_Reference --
1243 ----------------------
1245 function Pseudo_Reference
1246 (Container : aliased Map'Class) return Reference_Control_Type
1248 TC : constant Tamper_Counts_Access :=
1249 Container.Tree.TC'Unrestricted_Access;
1251 return R : constant Reference_Control_Type := (Controlled with TC) do
1254 end Pseudo_Reference;
1260 procedure Query_Element
1262 Process : not null access procedure (Key : Key_Type;
1263 Element : Element_Type))
1266 if Checks and then Position.Node = null then
1267 raise Constraint_Error with
1268 "Position cursor of Query_Element equals No_Element";
1272 (Position.Node.Key = null or else Position.Node.Element = null)
1274 raise Program_Error with
1275 "Position cursor of Query_Element is bad";
1278 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1279 "Position cursor of Query_Element is bad");
1282 T : Tree_Type renames Position.Container.Tree;
1283 Lock : With_Lock (T.TC'Unrestricted_Access);
1284 K : Key_Type renames Position.Node.Key.all;
1285 E : Element_Type renames Position.Node.Element.all;
1296 (Stream : not null access Root_Stream_Type'Class;
1297 Container : out Map)
1300 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1301 pragma Inline (Read_Node);
1304 new Tree_Operations.Generic_Read (Clear, Read_Node);
1311 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1313 Node : Node_Access := new Node_Type;
1315 Node.Key := new Key_Type'(Key_Type
'Input (Stream
));
1316 Node
.Element
:= new Element_Type
'(Element_Type'Input (Stream));
1320 Free (Node); -- Note that Free deallocates key and elem too
1324 -- Start of processing for Read
1327 Read (Stream, Container.Tree);
1331 (Stream : not null access Root_Stream_Type'Class;
1335 raise Program_Error with "attempt to stream map cursor";
1339 (Stream : not null access Root_Stream_Type'Class;
1340 Item : out Reference_Type)
1343 raise Program_Error with "attempt to stream reference";
1347 (Stream : not null access Root_Stream_Type'Class;
1348 Item : out Constant_Reference_Type)
1351 raise Program_Error with "attempt to stream reference";
1359 (Container : aliased in out Map;
1360 Position : Cursor) return Reference_Type
1363 if Checks and then Position.Container = null then
1364 raise Constraint_Error with
1365 "Position cursor has no element";
1368 if Checks and then Position.Container /= Container'Unrestricted_Access
1370 raise Program_Error with
1371 "Position cursor designates wrong map";
1374 if Checks and then Position.Node.Element = null then
1375 raise Program_Error with "Node has no element";
1378 pragma Assert (Vet (Container.Tree, Position.Node),
1379 "Position cursor in function Reference is bad");
1382 TC : constant Tamper_Counts_Access :=
1383 Container.Tree.TC'Unrestricted_Access;
1385 return R : constant Reference_Type :=
1386 (Element => Position.Node.Element.all'Access,
1387 Control => (Controlled with TC))
1395 (Container : aliased in out Map;
1396 Key : Key_Type) return Reference_Type
1398 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1401 if Checks and then Node = null then
1402 raise Constraint_Error with "key not in map";
1405 if Checks and then Node.Element = null then
1406 raise Program_Error with "Node has no element";
1410 TC : constant Tamper_Counts_Access :=
1411 Container.Tree.TC'Unrestricted_Access;
1413 return R : constant Reference_Type :=
1414 (Element => Node.Element.all'Access,
1415 Control => (Controlled with TC))
1427 (Container : in out Map;
1429 New_Item : Element_Type)
1431 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1437 if Checks and then Node = null then
1438 raise Constraint_Error with "key not in map";
1441 TE_Check (Container.Tree.TC);
1446 Node.Key := new Key_Type'(Key
);
1449 -- The element allocator may need an accessibility check in the case
1450 -- the actual type is class-wide or has access discriminants (see
1451 -- RM 4.8(10.1) and AI12-0035).
1453 pragma Unsuppress
(Accessibility_Check
);
1456 Node
.Element
:= new Element_Type
'(New_Item);
1468 ---------------------
1469 -- Replace_Element --
1470 ---------------------
1472 procedure Replace_Element
1473 (Container : in out Map;
1475 New_Item : Element_Type)
1478 if Checks and then Position.Node = null then
1479 raise Constraint_Error with
1480 "Position cursor of Replace_Element equals No_Element";
1484 (Position.Node.Key = null or else Position.Node.Element = null)
1486 raise Program_Error with
1487 "Position cursor of Replace_Element is bad";
1490 if Checks and then Position.Container /= Container'Unrestricted_Access
1492 raise Program_Error with
1493 "Position cursor of Replace_Element designates wrong map";
1496 TE_Check (Container.Tree.TC);
1498 pragma Assert (Vet (Container.Tree, Position.Node),
1499 "Position cursor of Replace_Element is bad");
1502 X : Element_Access := Position.Node.Element;
1504 -- The element allocator may need an accessibility check in the case
1505 -- the actual type is class-wide or has access discriminants (see
1506 -- RM 4.8(10.1) and AI12-0035).
1508 pragma Unsuppress (Accessibility_Check);
1511 Position.Node.Element := new Element_Type'(New_Item
);
1514 end Replace_Element
;
1516 ---------------------
1517 -- Reverse_Iterate --
1518 ---------------------
1520 procedure Reverse_Iterate
1522 Process
: not null access procedure (Position
: Cursor
))
1524 procedure Process_Node
(Node
: Node_Access
);
1525 pragma Inline
(Process_Node
);
1527 procedure Local_Reverse_Iterate
is
1528 new Tree_Operations
.Generic_Reverse_Iteration
(Process_Node
);
1534 procedure Process_Node
(Node
: Node_Access
) is
1536 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1539 Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
1541 -- Start of processing for Reverse_Iterate
1544 Local_Reverse_Iterate (Container.Tree);
1545 end Reverse_Iterate;
1551 function Right (Node : Node_Access) return Node_Access is
1560 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1562 Node.Color := Color;
1569 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1578 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1580 Node.Parent := Parent;
1587 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1589 Node.Right := Right;
1592 --------------------
1593 -- Update_Element --
1594 --------------------
1596 procedure Update_Element
1597 (Container : in out Map;
1599 Process : not null access procedure (Key : Key_Type;
1600 Element : in out Element_Type))
1603 if Checks and then Position.Node = null then
1604 raise Constraint_Error with
1605 "Position cursor of Update_Element equals No_Element";
1609 (Position.Node.Key = null or else Position.Node.Element = null)
1611 raise Program_Error with
1612 "Position cursor of Update_Element is bad";
1615 if Checks and then Position.Container /= Container'Unrestricted_Access
1617 raise Program_Error with
1618 "Position cursor of Update_Element designates wrong map";
1621 pragma Assert (Vet (Container.Tree, Position.Node),
1622 "Position cursor of Update_Element is bad");
1625 T : Tree_Type renames Position.Container.Tree;
1626 Lock : With_Lock (T.TC'Unrestricted_Access);
1627 K : Key_Type renames Position.Node.Key.all;
1628 E : Element_Type renames Position.Node.Element.all;
1639 (Stream : not null access Root_Stream_Type'Class;
1642 procedure Write_Node
1643 (Stream : not null access Root_Stream_Type'Class;
1644 Node : Node_Access);
1645 pragma Inline (Write_Node);
1648 new Tree_Operations.Generic_Write (Write_Node);
1654 procedure Write_Node
1655 (Stream : not null access Root_Stream_Type'Class;
1659 Key_Type'Output (Stream, Node.Key.all);
1660 Element_Type'Output (Stream, Node.Element.all);
1663 -- Start of processing for Write
1666 Write (Stream, Container.Tree);
1670 (Stream : not null access Root_Stream_Type'Class;
1674 raise Program_Error with "attempt to stream map cursor";
1678 (Stream : not null access Root_Stream_Type'Class;
1679 Item : Reference_Type)
1682 raise Program_Error with "attempt to stream reference";
1686 (Stream : not null access Root_Stream_Type'Class;
1687 Item : Constant_Reference_Type)
1690 raise Program_Error with "attempt to stream reference";
1693 end Ada.Containers.Indefinite_Ordered_Maps;