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