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-2019, 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;
42 package body Ada.Containers.Bounded_Ordered_Maps is
44 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
45 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
46 -- See comment in Ada.Containers.Helpers
48 -----------------------------
49 -- Node Access Subprograms --
50 -----------------------------
52 -- These subprograms provide a functional interface to access fields
53 -- of a node, and a procedural interface for modifying these values.
55 function Color (Node : Node_Type) return Color_Type;
56 pragma Inline (Color);
58 function Left (Node : Node_Type) return Count_Type;
61 function Parent (Node : Node_Type) return Count_Type;
62 pragma Inline (Parent);
64 function Right (Node : Node_Type) return Count_Type;
65 pragma Inline (Right);
67 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
68 pragma Inline (Set_Parent);
70 procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
71 pragma Inline (Set_Left);
73 procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
74 pragma Inline (Set_Right);
76 procedure Set_Color (Node : in out Node_Type; Color : Color_Type);
77 pragma Inline (Set_Color);
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 function Is_Greater_Key_Node
85 Right : Node_Type) return Boolean;
86 pragma Inline (Is_Greater_Key_Node);
88 function Is_Less_Key_Node
90 Right : Node_Type) return Boolean;
91 pragma Inline (Is_Less_Key_Node);
93 --------------------------
94 -- Local Instantiations --
95 --------------------------
97 package Tree_Operations is
98 new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types);
103 new Red_Black_Trees.Generic_Bounded_Keys
104 (Tree_Operations => Tree_Operations,
105 Key_Type => Key_Type,
106 Is_Less_Key_Node => Is_Less_Key_Node,
107 Is_Greater_Key_Node => Is_Greater_Key_Node);
113 function "<" (Left, Right : Cursor) return Boolean is
115 if Checks and then Left.Node = 0 then
116 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
119 if Checks and then Right.Node = 0 then
120 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
123 pragma Assert (Vet (Left.Container.all, Left.Node),
124 "Left cursor of ""<"" is bad");
126 pragma Assert (Vet (Right.Container.all, Right.Node),
127 "Right cursor of ""<"" is bad");
130 LN : Node_Type renames Left.Container.Nodes (Left.Node);
131 RN : Node_Type renames Right.Container.Nodes (Right.Node);
134 return LN.Key < RN.Key;
138 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
140 if Checks and then Left.Node = 0 then
141 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
144 pragma Assert (Vet (Left.Container.all, Left.Node),
145 "Left cursor of ""<"" is bad");
148 LN : Node_Type renames Left.Container.Nodes (Left.Node);
151 return LN.Key < Right;
155 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
157 if Checks and then Right.Node = 0 then
158 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
161 pragma Assert (Vet (Right.Container.all, Right.Node),
162 "Right cursor of ""<"" is bad");
165 RN : Node_Type renames Right.Container.Nodes (Right.Node);
168 return Left < RN.Key;
176 function "=" (Left, Right : Map) return Boolean is
177 function Is_Equal_Node_Node (L, R : Node_Type) return Boolean;
178 pragma Inline (Is_Equal_Node_Node);
181 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
183 ------------------------
184 -- Is_Equal_Node_Node --
185 ------------------------
187 function Is_Equal_Node_Node
188 (L, R : Node_Type) return Boolean is
190 if L.Key < R.Key then
193 elsif R.Key < L.Key then
197 return L.Element = R.Element;
199 end Is_Equal_Node_Node;
201 -- Start of processing for "="
204 return Is_Equal (Left, Right);
211 function ">" (Left, Right : Cursor) return Boolean is
213 if Checks and then Left.Node = 0 then
214 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
217 if Checks and then Right.Node = 0 then
218 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
221 pragma Assert (Vet (Left.Container.all, Left.Node),
222 "Left cursor of "">"" is bad");
224 pragma Assert (Vet (Right.Container.all, Right.Node),
225 "Right cursor of "">"" is bad");
228 LN : Node_Type renames Left.Container.Nodes (Left.Node);
229 RN : Node_Type renames Right.Container.Nodes (Right.Node);
232 return RN.Key < LN.Key;
236 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
238 if Checks and then Left.Node = 0 then
239 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
242 pragma Assert (Vet (Left.Container.all, Left.Node),
243 "Left cursor of "">"" is bad");
246 LN : Node_Type renames Left.Container.Nodes (Left.Node);
248 return Right < LN.Key;
252 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
254 if Checks and then Right.Node = 0 then
255 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
258 pragma Assert (Vet (Right.Container.all, Right.Node),
259 "Right cursor of "">"" is bad");
262 RN : Node_Type renames Right.Container.Nodes (Right.Node);
265 return RN.Key < Left;
273 procedure Assign (Target : in out Map; Source : Map) is
274 procedure Append_Element (Source_Node : Count_Type);
276 procedure Append_Elements is
277 new Tree_Operations.Generic_Iteration (Append_Element);
283 procedure Append_Element (Source_Node : Count_Type) is
284 SN : Node_Type renames Source.Nodes (Source_Node);
286 procedure Set_Element (Node : in out Node_Type);
287 pragma Inline (Set_Element);
289 function New_Node return Count_Type;
290 pragma Inline (New_Node);
292 procedure Insert_Post is
293 new Key_Ops.Generic_Insert_Post (New_Node);
295 procedure Unconditional_Insert_Sans_Hint is
296 new Key_Ops.Generic_Unconditional_Insert (Insert_Post);
298 procedure Unconditional_Insert_Avec_Hint is
299 new Key_Ops.Generic_Unconditional_Insert_With_Hint
301 Unconditional_Insert_Sans_Hint);
303 procedure Allocate is
304 new Tree_Operations.Generic_Allocate (Set_Element);
310 function New_Node return Count_Type is
314 Allocate (Target, Result);
322 procedure Set_Element (Node : in out Node_Type) is
325 Node.Element := SN.Element;
328 Target_Node : Count_Type;
330 -- Start of processing for Append_Element
333 Unconditional_Insert_Avec_Hint
337 Node => Target_Node);
340 -- Start of processing for Assign
343 if Target'Address = Source'Address then
347 if Checks and then Target.Capacity < Source.Length then
349 with "Target capacity is less than Source length";
352 Tree_Operations.Clear_Tree (Target);
353 Append_Elements (Source);
360 function Ceiling (Container : Map; Key : Key_Type) return Cursor is
361 Node : constant Count_Type := Key_Ops.Ceiling (Container, Key);
368 return Cursor'(Container'Unrestricted_Access, Node);
375 procedure Clear (Container : in out Map) is
377 while not Container.Is_Empty loop
378 Container.Delete_Last;
386 function Color (Node : Node_Type) return Color_Type is
391 ------------------------
392 -- Constant_Reference --
393 ------------------------
395 function Constant_Reference
396 (Container : aliased Map;
397 Position : Cursor) return Constant_Reference_Type
400 if Checks and then Position.Container = null then
401 raise Constraint_Error with
402 "Position cursor has no element";
405 if Checks and then Position.Container /= Container'Unrestricted_Access
407 raise Program_Error with
408 "Position cursor designates wrong map";
411 pragma Assert (Vet (Container, Position.Node),
412 "Position cursor in Constant_Reference is bad");
415 N : Node_Type renames Container.Nodes (Position.Node);
416 TC : constant Tamper_Counts_Access :=
417 Container.TC'Unrestricted_Access;
419 return R : constant Constant_Reference_Type :=
420 (Element => N.Element'Access,
421 Control => (Controlled with TC))
426 end Constant_Reference;
428 function Constant_Reference
429 (Container : aliased Map;
430 Key : Key_Type) return Constant_Reference_Type
432 Node : constant Count_Type := Key_Ops.Find (Container, Key);
435 if Checks and then Node = 0 then
436 raise Constraint_Error with "key not in map";
440 N : Node_Type renames Container.Nodes (Node);
441 TC : constant Tamper_Counts_Access :=
442 Container.TC'Unrestricted_Access;
444 return R : constant Constant_Reference_Type :=
445 (Element => N.Element'Access,
446 Control => (Controlled with TC))
451 end Constant_Reference;
457 function Contains (Container : Map; Key : Key_Type) return Boolean is
459 return Find (Container, Key) /= No_Element;
466 function Copy (Source : Map; Capacity : Count_Type := 0) return Map is
473 elsif Capacity >= Source.Length then
477 raise Capacity_Error with "Capacity value too small";
480 return Target : Map (Capacity => C) do
481 Assign (Target => Target, Source => Source);
489 procedure Delete (Container : in out Map; Position : in out Cursor) is
491 if Checks and then Position.Node = 0 then
492 raise Constraint_Error with
493 "Position cursor of Delete equals No_Element";
496 if Checks and then Position.Container /= Container'Unrestricted_Access
498 raise Program_Error with
499 "Position cursor of Delete designates wrong map";
502 pragma Assert (Vet (Container, Position.Node),
503 "Position cursor of Delete is bad");
505 Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
506 Tree_Operations.Free (Container, Position.Node);
508 Position := No_Element;
511 procedure Delete (Container : in out Map; Key : Key_Type) is
512 X : constant Count_Type := Key_Ops.Find (Container, Key);
515 if Checks and then X = 0 then
516 raise Constraint_Error with "key not in map";
519 Tree_Operations.Delete_Node_Sans_Free (Container, X);
520 Tree_Operations.Free (Container, X);
527 procedure Delete_First (Container : in out Map) is
528 X : constant Count_Type := Container.First;
532 Tree_Operations.Delete_Node_Sans_Free (Container, X);
533 Tree_Operations.Free (Container, X);
541 procedure Delete_Last (Container : in out Map) is
542 X : constant Count_Type := Container.Last;
546 Tree_Operations.Delete_Node_Sans_Free (Container, X);
547 Tree_Operations.Free (Container, X);
555 function Element (Position : Cursor) return Element_Type is
557 if Checks and then Position.Node = 0 then
558 raise Constraint_Error with
559 "Position cursor of function Element equals No_Element";
562 pragma Assert (Vet (Position.Container.all, Position.Node),
563 "Position cursor of function Element is bad");
565 return Position.Container.Nodes (Position.Node).Element;
568 function Element (Container : Map; Key : Key_Type) return Element_Type is
569 Node : constant Count_Type := Key_Ops.Find (Container, Key);
571 if Checks and then Node = 0 then
572 raise Constraint_Error with "key not in map";
575 return Container.Nodes (Node).Element;
578 ---------------------
579 -- Equivalent_Keys --
580 ---------------------
582 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
597 procedure Exclude (Container : in out Map; Key : Key_Type) is
598 X : constant Count_Type := Key_Ops.Find (Container, Key);
602 Tree_Operations.Delete_Node_Sans_Free (Container, X);
603 Tree_Operations.Free (Container, X);
611 procedure Finalize (Object : in out Iterator) is
613 if Object.Container /= null then
614 Unbusy (Object.Container.TC);
622 function Find (Container : Map; Key : Key_Type) return Cursor is
623 Node : constant Count_Type := Key_Ops.Find (Container, Key);
628 return Cursor'(Container'Unrestricted_Access, Node);
636 function First (Container : Map) return Cursor is
638 if Container.First = 0 then
641 return Cursor'(Container'Unrestricted_Access, Container.First);
645 function First (Object : Iterator) return Cursor is
647 -- The value of the iterator object's Node component influences the
648 -- behavior of the First (and Last) selector function.
650 -- When the Node component is 0, this means the iterator object was
651 -- constructed without a start expression, in which case the (forward)
652 -- iteration starts from the (logical) beginning of the entire sequence
653 -- of items (corresponding to Container.First, for a forward iterator).
655 -- Otherwise, this is iteration over a partial sequence of items. When
656 -- the Node component is positive, the iterator object was constructed
657 -- with a start expression, that specifies the position from which the
658 -- (forward) partial iteration begins.
660 if Object.Node = 0 then
661 return Bounded_Ordered_Maps.First (Object.Container.all);
663 return Cursor'(Object.Container, Object.Node);
671 function First_Element (Container : Map) return Element_Type is
673 if Checks and then Container.First = 0 then
674 raise Constraint_Error with "map is empty";
677 return Container.Nodes (Container.First).Element;
684 function First_Key (Container : Map) return Key_Type is
686 if Checks and then Container.First = 0 then
687 raise Constraint_Error with "map is empty";
690 return Container.Nodes (Container.First).Key;
697 function Floor (Container : Map; Key : Key_Type) return Cursor is
698 Node : constant Count_Type := Key_Ops.Floor (Container, Key);
703 return Cursor'(Container'Unrestricted_Access, Node);
707 ------------------------
708 -- Get_Element_Access --
709 ------------------------
711 function Get_Element_Access
712 (Position : Cursor) return not null Element_Access is
714 return Position.Container.Nodes (Position.Node).Element'Access;
715 end Get_Element_Access;
721 function Has_Element (Position : Cursor) return Boolean is
723 return Position /= No_Element;
731 (Container : in out Map;
733 New_Item : Element_Type)
739 Insert (Container, Key, New_Item, Position, Inserted);
742 TE_Check (Container.TC);
745 N : Node_Type renames Container.Nodes (Position.Node);
748 N.Element := New_Item;
758 (Container : in out Map;
760 New_Item : Element_Type;
761 Position : out Cursor;
762 Inserted : out Boolean)
764 procedure Assign (Node : in out Node_Type);
765 pragma Inline (Assign);
767 function New_Node return Count_Type;
768 pragma Inline (New_Node);
770 procedure Insert_Post is
771 new Key_Ops.Generic_Insert_Post (New_Node);
773 procedure Insert_Sans_Hint is
774 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
776 procedure Allocate is
777 new Tree_Operations.Generic_Allocate (Assign);
783 procedure Assign (Node : in out Node_Type) is
786 Node.Element := New_Item;
793 function New_Node return Count_Type is
796 Allocate (Container, Result);
800 -- Start of processing for Insert
809 Position.Container := Container'Unrestricted_Access;
813 (Container : in out Map;
815 New_Item : Element_Type)
818 pragma Unreferenced (Position);
823 Insert (Container, Key, New_Item, Position, Inserted);
825 if Checks and then not Inserted then
826 raise Constraint_Error with "key already in map";
831 (Container : in out Map;
833 Position : out Cursor;
834 Inserted : out Boolean)
836 procedure Assign (Node : in out Node_Type);
837 pragma Inline (Assign);
839 function New_Node return Count_Type;
840 pragma Inline (New_Node);
842 procedure Insert_Post is
843 new Key_Ops.Generic_Insert_Post (New_Node);
845 procedure Insert_Sans_Hint is
846 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
848 procedure Allocate is
849 new Tree_Operations.Generic_Allocate (Assign);
855 procedure Assign (Node : in out Node_Type) is
856 pragma Warnings (Off);
857 Default_Initialized_Item : Element_Type;
858 pragma Unmodified (Default_Initialized_Item);
859 -- Default-initialized element (ok to reference, see below)
864 -- There is no explicit element provided, but in an instance the element
865 -- type may be a scalar with a Default_Value aspect, or a composite type
866 -- with such a scalar component or with defaulted components, so insert
867 -- possibly initialized elements at the given position.
869 Node.Element := Default_Initialized_Item;
870 pragma Warnings (On);
877 function New_Node return Count_Type is
880 Allocate (Container, Result);
884 -- Start of processing for Insert
893 Position.Container := Container'Unrestricted_Access;
900 function Is_Empty (Container : Map) return Boolean is
902 return Container.Length = 0;
905 -------------------------
906 -- Is_Greater_Key_Node --
907 -------------------------
909 function Is_Greater_Key_Node
911 Right : Node_Type) return Boolean
914 -- Left > Right same as Right < Left
916 return Right.Key < Left;
917 end Is_Greater_Key_Node;
919 ----------------------
920 -- Is_Less_Key_Node --
921 ----------------------
923 function Is_Less_Key_Node
925 Right : Node_Type) return Boolean
928 return Left < Right.Key;
929 end Is_Less_Key_Node;
937 Process : not null access procedure (Position : Cursor))
939 procedure Process_Node (Node : Count_Type);
940 pragma Inline (Process_Node);
942 procedure Local_Iterate is
943 new Tree_Operations.Generic_Iteration (Process_Node);
949 procedure Process_Node (Node : Count_Type) is
951 Process (Cursor'(Container'Unrestricted_Access, Node));
954 Busy : With_Busy (Container.TC'Unrestricted_Access);
956 -- Start of processing for Iterate
959 Local_Iterate (Container);
963 (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
966 -- The value of the Node component influences the behavior of the First
967 -- and Last selector functions of the iterator object. When the Node
968 -- component is 0 (as is the case here), this means the iterator object
969 -- was constructed without a start expression. This is a complete
970 -- iterator, meaning that the iteration starts from the (logical)
971 -- beginning of the sequence of items.
973 -- Note: For a forward iterator, Container.First is the beginning, and
974 -- for a reverse iterator, Container.Last is the beginning.
976 return It : constant Iterator :=
977 (Limited_Controlled with
978 Container => Container'Unrestricted_Access,
981 Busy (Container.TC'Unrestricted_Access.all);
988 return Map_Iterator_Interfaces.Reversible_Iterator'Class
991 -- Iterator was defined to behave the same as for a complete iterator,
992 -- and iterate over the entire sequence of items. However, those
993 -- semantics were unintuitive and arguably error-prone (it is too easy
994 -- to accidentally create an endless loop), and so they were changed,
995 -- per the ARG meeting in Denver on 2011/11. However, there was no
996 -- consensus about what positive meaning this corner case should have,
997 -- and so it was decided to simply raise an exception. This does imply,
998 -- however, that it is not possible to use a partial iterator to specify
999 -- an empty sequence of items.
1001 if Checks and then Start = No_Element then
1002 raise Constraint_Error with
1003 "Start position for iterator equals No_Element";
1006 if Checks and then Start.Container /= Container'Unrestricted_Access then
1007 raise Program_Error with
1008 "Start cursor of Iterate designates wrong map";
1011 pragma Assert (Vet (Container, Start.Node),
1012 "Start cursor of Iterate is bad");
1014 -- The value of the Node component influences the behavior of the First
1015 -- and Last selector functions of the iterator object. When the Node
1016 -- component is positive (as is the case here), it means that this
1017 -- is a partial iteration, over a subset of the complete sequence of
1018 -- items. The iterator object was constructed with a start expression,
1019 -- indicating the position from which the iteration begins. (Note that
1020 -- the start position has the same value irrespective of whether this
1021 -- is a forward or reverse iteration.)
1023 return It : constant Iterator :=
1024 (Limited_Controlled with
1025 Container => Container'Unrestricted_Access,
1028 Busy (Container.TC'Unrestricted_Access.all);
1036 function Key (Position : Cursor) return Key_Type is
1038 if Checks and then Position.Node = 0 then
1039 raise Constraint_Error with
1040 "Position cursor of function Key equals No_Element";
1043 pragma Assert (Vet (Position.Container.all, Position.Node),
1044 "Position cursor of function Key is bad");
1046 return Position.Container.Nodes (Position.Node).Key;
1053 function Last (Container : Map) return Cursor is
1055 if Container.Last = 0 then
1058 return Cursor'(Container'Unrestricted_Access, Container.Last);
1062 function Last (Object : Iterator) return Cursor is
1064 -- The value of the iterator object's Node component influences the
1065 -- behavior of the Last (and First) selector function.
1067 -- When the Node component is 0, this means the iterator object was
1068 -- constructed without a start expression, in which case the (reverse)
1069 -- iteration starts from the (logical) beginning of the entire sequence
1070 -- (corresponding to Container.Last, for a reverse iterator).
1072 -- Otherwise, this is iteration over a partial sequence of items. When
1073 -- the Node component is positive, the iterator object was constructed
1074 -- with a start expression, that specifies the position from which the
1075 -- (reverse) partial iteration begins.
1077 if Object.Node = 0 then
1078 return Bounded_Ordered_Maps.Last (Object.Container.all);
1080 return Cursor'(Object.Container, Object.Node);
1088 function Last_Element (Container : Map) return Element_Type is
1090 if Checks and then Container.Last = 0 then
1091 raise Constraint_Error with "map is empty";
1094 return Container.Nodes (Container.Last).Element;
1101 function Last_Key (Container : Map) return Key_Type is
1103 if Checks and then Container.Last = 0 then
1104 raise Constraint_Error with "map is empty";
1107 return Container.Nodes (Container.Last).Key;
1114 function Left (Node : Node_Type) return Count_Type is
1123 function Length (Container : Map) return Count_Type is
1125 return Container.Length;
1132 procedure Move (Target : in out Map; Source : in out Map) is
1134 if Target'Address = Source'Address then
1138 TC_Check (Source.TC);
1140 Target.Assign (Source);
1148 procedure Next (Position : in out Cursor) is
1150 Position := Next (Position);
1153 function Next (Position : Cursor) return Cursor is
1155 if Position = No_Element then
1159 pragma Assert (Vet (Position.Container.all, Position.Node),
1160 "Position cursor of Next is bad");
1163 M : Map renames Position.Container.all;
1165 Node : constant Count_Type :=
1166 Tree_Operations.Next (M, Position.Node);
1173 return Cursor'(Position.Container, Node);
1179 Position : Cursor) return Cursor
1182 if Position.Container = null then
1186 if Checks and then Position.Container /= Object.Container then
1187 raise Program_Error with
1188 "Position cursor of Next designates wrong map";
1191 return Next (Position);
1198 function Parent (Node : Node_Type) return Count_Type is
1207 procedure Previous (Position : in out Cursor) is
1209 Position := Previous (Position);
1212 function Previous (Position : Cursor) return Cursor is
1214 if Position = No_Element then
1218 pragma Assert (Vet (Position.Container.all, Position.Node),
1219 "Position cursor of Previous is bad");
1222 M : Map renames Position.Container.all;
1224 Node : constant Count_Type :=
1225 Tree_Operations.Previous (M, Position.Node);
1232 return Cursor'(Position.Container, Node);
1238 Position : Cursor) return Cursor
1241 if Position.Container = null then
1245 if Checks and then Position.Container /= Object.Container then
1246 raise Program_Error with
1247 "Position cursor of Previous designates wrong map";
1250 return Previous (Position);
1253 ----------------------
1254 -- Pseudo_Reference --
1255 ----------------------
1257 function Pseudo_Reference
1258 (Container : aliased Map'Class) return Reference_Control_Type
1260 TC : constant Tamper_Counts_Access :=
1261 Container.TC'Unrestricted_Access;
1263 return R : constant Reference_Control_Type := (Controlled with TC) do
1266 end Pseudo_Reference;
1272 procedure Query_Element
1274 Process : not null access procedure (Key : Key_Type;
1275 Element : Element_Type))
1278 if Checks and then Position.Node = 0 then
1279 raise Constraint_Error with
1280 "Position cursor of Query_Element equals No_Element";
1283 pragma Assert (Vet (Position.Container.all, Position.Node),
1284 "Position cursor of Query_Element is bad");
1287 M : Map renames Position.Container.all;
1288 N : Node_Type renames M.Nodes (Position.Node);
1289 Lock : With_Lock (M.TC'Unrestricted_Access);
1291 Process (N.Key, N.Element);
1300 (Stream : not null access Root_Stream_Type'Class;
1301 Container : out Map)
1303 procedure Read_Element (Node : in out Node_Type);
1304 pragma Inline (Read_Element);
1306 procedure Allocate is
1307 new Tree_Operations.Generic_Allocate (Read_Element);
1309 procedure Read_Elements is
1310 new Tree_Operations.Generic_Read (Allocate);
1316 procedure Read_Element (Node : in out Node_Type) is
1318 Key_Type'Read (Stream, Node.Key);
1319 Element_Type'Read (Stream, Node.Element);
1322 -- Start of processing for Read
1325 Read_Elements (Stream, Container);
1329 (Stream : not null access Root_Stream_Type'Class;
1333 raise Program_Error with "attempt to stream map cursor";
1337 (Stream : not null access Root_Stream_Type'Class;
1338 Item : out Reference_Type)
1341 raise Program_Error with "attempt to stream reference";
1345 (Stream : not null access Root_Stream_Type'Class;
1346 Item : out Constant_Reference_Type)
1349 raise Program_Error with "attempt to stream reference";
1357 (Container : aliased in out Map;
1358 Position : Cursor) return Reference_Type
1361 if Checks and then Position.Container = null then
1362 raise Constraint_Error with
1363 "Position cursor has no element";
1366 if Checks and then Position.Container /= Container'Unrestricted_Access
1368 raise Program_Error with
1369 "Position cursor designates wrong map";
1372 pragma Assert (Vet (Container, Position.Node),
1373 "Position cursor in function Reference is bad");
1376 N : Node_Type renames Container.Nodes (Position.Node);
1377 TC : constant Tamper_Counts_Access :=
1378 Container.TC'Unrestricted_Access;
1380 return R : constant Reference_Type :=
1381 (Element => N.Element'Access,
1382 Control => (Controlled with TC))
1390 (Container : aliased in out Map;
1391 Key : Key_Type) return Reference_Type
1393 Node : constant Count_Type := Key_Ops.Find (Container, Key);
1396 if Checks and then Node = 0 then
1397 raise Constraint_Error with "key not in map";
1401 N : Node_Type renames Container.Nodes (Node);
1402 TC : constant Tamper_Counts_Access :=
1403 Container.TC'Unrestricted_Access;
1405 return R : constant Reference_Type :=
1406 (Element => N.Element'Access,
1407 Control => (Controlled with TC))
1419 (Container : in out Map;
1421 New_Item : Element_Type)
1423 Node : constant Count_Type := Key_Ops.Find (Container, Key);
1426 if Checks and then Node = 0 then
1427 raise Constraint_Error with "key not in map";
1430 TE_Check (Container.TC);
1433 N : Node_Type renames Container.Nodes (Node);
1437 N.Element := New_Item;
1441 ---------------------
1442 -- Replace_Element --
1443 ---------------------
1445 procedure Replace_Element
1446 (Container : in out Map;
1448 New_Item : Element_Type)
1451 if Checks and then Position.Node = 0 then
1452 raise Constraint_Error with
1453 "Position cursor of Replace_Element equals No_Element";
1456 if Checks and then Position.Container /= Container'Unrestricted_Access
1458 raise Program_Error with
1459 "Position cursor of Replace_Element designates wrong map";
1462 TE_Check (Container.TC);
1464 pragma Assert (Vet (Container, Position.Node),
1465 "Position cursor of Replace_Element is bad");
1467 Container.Nodes (Position.Node).Element := New_Item;
1468 end Replace_Element;
1470 ---------------------
1471 -- Reverse_Iterate --
1472 ---------------------
1474 procedure Reverse_Iterate
1476 Process : not null access procedure (Position : Cursor))
1478 procedure Process_Node (Node : Count_Type);
1479 pragma Inline (Process_Node);
1481 procedure Local_Reverse_Iterate is
1482 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1488 procedure Process_Node (Node : Count_Type) is
1490 Process (Cursor'(Container'Unrestricted_Access, Node));
1493 Busy : With_Busy (Container.TC'Unrestricted_Access);
1495 -- Start of processing for Reverse_Iterate
1498 Local_Reverse_Iterate (Container);
1499 end Reverse_Iterate;
1505 function Right (Node : Node_Type) return Count_Type is
1515 (Node : in out Node_Type;
1519 Node.Color := Color;
1526 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
1535 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
1537 Node.Parent := Parent;
1544 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
1546 Node.Right := Right;
1549 --------------------
1550 -- Update_Element --
1551 --------------------
1553 procedure Update_Element
1554 (Container : in out Map;
1556 Process : not null access procedure (Key : Key_Type;
1557 Element : in out Element_Type))
1560 if Checks and then Position.Node = 0 then
1561 raise Constraint_Error with
1562 "Position cursor of Update_Element equals No_Element";
1565 if Checks and then Position.Container /= Container'Unrestricted_Access
1567 raise Program_Error with
1568 "Position cursor of Update_Element designates wrong map";
1571 pragma Assert (Vet (Container, Position.Node),
1572 "Position cursor of Update_Element is bad");
1575 N : Node_Type renames Container.Nodes (Position.Node);
1576 Lock : With_Lock (Container.TC'Unrestricted_Access);
1578 Process (N.Key, N.Element);
1587 (Stream : not null access Root_Stream_Type'Class;
1590 procedure Write_Node
1591 (Stream : not null access Root_Stream_Type'Class;
1593 pragma Inline (Write_Node);
1595 procedure Write_Nodes is
1596 new Tree_Operations.Generic_Write (Write_Node);
1602 procedure Write_Node
1603 (Stream : not null access Root_Stream_Type'Class;
1607 Key_Type'Write (Stream, Node.Key);
1608 Element_Type'Write (Stream, Node.Element);
1611 -- Start of processing for Write
1614 Write_Nodes (Stream, Container);
1618 (Stream : not null access Root_Stream_Type'Class;
1622 raise Program_Error with "attempt to stream map cursor";
1626 (Stream : not null access Root_Stream_Type'Class;
1627 Item : Reference_Type)
1630 raise Program_Error with "attempt to stream reference";
1634 (Stream : not null access Root_Stream_Type'Class;
1635 Item : Constant_Reference_Type)
1638 raise Program_Error with "attempt to stream reference";
1641 end Ada.Containers.Bounded_Ordered_Maps;