1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
9 -- Copyright (C) 2004-2009, 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.Red_Black_Trees.Generic_Operations;
33 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
35 with Ada.Containers.Red_Black_Trees.Generic_Keys;
36 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
38 package body Ada.Containers.Indefinite_Ordered_Maps is
40 -----------------------------
41 -- Node Access Subprograms --
42 -----------------------------
44 -- These subprograms provide a functional interface to access fields
45 -- of a node, and a procedural interface for modifying these values.
47 function Color (Node : Node_Access) return Color_Type;
48 pragma Inline (Color);
50 function Left (Node : Node_Access) return Node_Access;
53 function Parent (Node : Node_Access) return Node_Access;
54 pragma Inline (Parent);
56 function Right (Node : Node_Access) return Node_Access;
57 pragma Inline (Right);
59 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
60 pragma Inline (Set_Parent);
62 procedure Set_Left (Node : Node_Access; Left : Node_Access);
63 pragma Inline (Set_Left);
65 procedure Set_Right (Node : Node_Access; Right : Node_Access);
66 pragma Inline (Set_Right);
68 procedure Set_Color (Node : Node_Access; Color : Color_Type);
69 pragma Inline (Set_Color);
71 -----------------------
72 -- Local Subprograms --
73 -----------------------
75 function Copy_Node (Source : Node_Access) return Node_Access;
76 pragma Inline (Copy_Node);
78 procedure Free (X : in out Node_Access);
80 function Is_Equal_Node_Node
81 (L, R : Node_Access) return Boolean;
82 pragma Inline (Is_Equal_Node_Node);
84 function Is_Greater_Key_Node
86 Right : Node_Access) return Boolean;
87 pragma Inline (Is_Greater_Key_Node);
89 function Is_Less_Key_Node
91 Right : Node_Access) return Boolean;
92 pragma Inline (Is_Less_Key_Node);
94 --------------------------
95 -- Local Instantiations --
96 --------------------------
98 package Tree_Operations is
99 new Red_Black_Trees.Generic_Operations (Tree_Types);
101 procedure Delete_Tree is
102 new Tree_Operations.Generic_Delete_Tree (Free);
104 function Copy_Tree is
105 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
110 new Red_Black_Trees.Generic_Keys
111 (Tree_Operations => Tree_Operations,
112 Key_Type => Key_Type,
113 Is_Less_Key_Node => Is_Less_Key_Node,
114 Is_Greater_Key_Node => Is_Greater_Key_Node);
116 procedure Free_Key is
117 new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
119 procedure Free_Element is
120 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
123 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
129 function "<" (Left, Right : Cursor) return Boolean is
131 if Left.Node = null then
132 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
135 if Right.Node = null then
136 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
139 if Left.Node.Key = null then
140 raise Program_Error with "Left cursor in ""<"" is bad";
143 if Right.Node.Key = null then
144 raise Program_Error with "Right cursor in ""<"" is bad";
147 pragma Assert (Vet (Left.Container.Tree, Left.Node),
148 "Left cursor in ""<"" is bad");
150 pragma Assert (Vet (Right.Container.Tree, Right.Node),
151 "Right cursor in ""<"" is bad");
153 return Left.Node.Key.all < Right.Node.Key.all;
156 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
158 if Left.Node = null then
159 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
162 if Left.Node.Key = null then
163 raise Program_Error with "Left cursor in ""<"" is bad";
166 pragma Assert (Vet (Left.Container.Tree, Left.Node),
167 "Left cursor in ""<"" is bad");
169 return Left.Node.Key.all < Right;
172 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
174 if Right.Node = null then
175 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
178 if Right.Node.Key = null then
179 raise Program_Error with "Right cursor in ""<"" is bad";
182 pragma Assert (Vet (Right.Container.Tree, Right.Node),
183 "Right cursor in ""<"" is bad");
185 return Left < Right.Node.Key.all;
192 function "=" (Left, Right : Map) return Boolean is
194 return Is_Equal (Left.Tree, Right.Tree);
201 function ">" (Left, Right : Cursor) return Boolean is
203 if Left.Node = null then
204 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
207 if Right.Node = null then
208 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
211 if Left.Node.Key = null then
212 raise Program_Error with "Left cursor in ""<"" is bad";
215 if Right.Node.Key = null then
216 raise Program_Error with "Right cursor in ""<"" is bad";
219 pragma Assert (Vet (Left.Container.Tree, Left.Node),
220 "Left cursor in "">"" is bad");
222 pragma Assert (Vet (Right.Container.Tree, Right.Node),
223 "Right cursor in "">"" is bad");
225 return Right.Node.Key.all < Left.Node.Key.all;
228 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
230 if Left.Node = null then
231 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
234 if Left.Node.Key = null then
235 raise Program_Error with "Left cursor in ""<"" is bad";
238 pragma Assert (Vet (Left.Container.Tree, Left.Node),
239 "Left cursor in "">"" is bad");
241 return Right < Left.Node.Key.all;
244 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
246 if Right.Node = null then
247 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
250 if Right.Node.Key = null then
251 raise Program_Error with "Right cursor in ""<"" is bad";
254 pragma Assert (Vet (Right.Container.Tree, Right.Node),
255 "Right cursor in "">"" is bad");
257 return Right.Node.Key.all < Left;
265 new Tree_Operations.Generic_Adjust (Copy_Tree);
267 procedure Adjust (Container : in out Map) is
269 Adjust (Container.Tree);
276 function Ceiling (Container : Map; Key : Key_Type) return Cursor is
277 Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
284 return Cursor'(Container'Unrestricted_Access, Node);
292 new Tree_Operations.Generic_Clear (Delete_Tree);
294 procedure Clear (Container : in out Map) is
296 Clear (Container.Tree);
303 function Color (Node : Node_Access) return Color_Type is
312 function Contains (Container : Map; Key : Key_Type) return Boolean is
314 return Find (Container, Key) /= No_Element;
321 function Copy_Node (Source : Node_Access) return Node_Access is
322 K : Key_Access := new Key_Type'(Source.Key.all);
325 E := new Element_Type'(Source.Element.all);
327 return new Node_Type'(Parent => null,
330 Color => Source.Color,
345 (Container : in out Map;
346 Position : in out Cursor)
349 if Position.Node = null then
350 raise Constraint_Error with
351 "Position cursor of Delete equals No_Element";
354 if Position.Node.Key = null
355 or else Position.Node.Element = null
357 raise Program_Error with "Position cursor of Delete is bad";
360 if Position.Container /= Container'Unrestricted_Access then
361 raise Program_Error with
362 "Position cursor of Delete designates wrong map";
365 pragma Assert (Vet (Container.Tree, Position.Node),
366 "Position cursor of Delete is bad");
368 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
369 Free (Position.Node);
371 Position.Container := null;
374 procedure Delete (Container : in out Map; Key : Key_Type) is
375 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
379 raise Constraint_Error with "key not in map";
382 Delete_Node_Sans_Free (Container.Tree, X);
390 procedure Delete_First (Container : in out Map) is
391 X : Node_Access := Container.Tree.First;
395 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
404 procedure Delete_Last (Container : in out Map) is
405 X : Node_Access := Container.Tree.Last;
409 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
418 function Element (Position : Cursor) return Element_Type is
420 if Position.Node = null then
421 raise Constraint_Error with
422 "Position cursor of function Element equals No_Element";
425 if Position.Node.Element = null then
426 raise Program_Error with
427 "Position cursor of function Element is bad";
430 pragma Assert (Vet (Position.Container.Tree, Position.Node),
431 "Position cursor of function Element is bad");
433 return Position.Node.Element.all;
436 function Element (Container : Map; Key : Key_Type) return Element_Type is
437 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
441 raise Constraint_Error with "key not in map";
444 return Node.Element.all;
447 ---------------------
448 -- Equivalent_Keys --
449 ---------------------
451 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
466 procedure Exclude (Container : in out Map; Key : Key_Type) is
467 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
471 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
480 function Find (Container : Map; Key : Key_Type) return Cursor is
481 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
488 return Cursor'(Container'Unrestricted_Access, Node);
495 function First (Container : Map) return Cursor is
496 T : Tree_Type renames Container.Tree;
499 if T.First = null then
503 return Cursor'(Container'Unrestricted_Access, T.First);
510 function First_Element (Container : Map) return Element_Type is
511 T : Tree_Type renames Container.Tree;
514 if T.First = null then
515 raise Constraint_Error with "map is empty";
518 return T.First.Element.all;
525 function First_Key (Container : Map) return Key_Type is
526 T : Tree_Type renames Container.Tree;
529 if T.First = null then
530 raise Constraint_Error with "map is empty";
533 return T.First.Key.all;
540 function Floor (Container : Map; Key : Key_Type) return Cursor is
541 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
548 return Cursor'(Container'Unrestricted_Access, Node);
555 procedure Free (X : in out Node_Access) is
556 procedure Deallocate is
557 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
575 Free_Element (X.Element);
586 Free_Element (X.Element);
602 function Has_Element (Position : Cursor) return Boolean is
604 return Position /= No_Element;
612 (Container : in out Map;
614 New_Item : Element_Type)
623 Insert (Container, Key, New_Item, Position, Inserted);
626 if Container.Tree.Lock > 0 then
627 raise Program_Error with
628 "attempt to tamper with cursors (map is locked)";
631 K := Position.Node.Key;
632 E := Position.Node.Element;
634 Position.Node.Key := new Key_Type'(Key);
637 Position.Node.Element := new Element_Type'(New_Item);
654 (Container : in out Map;
656 New_Item : Element_Type;
657 Position : out Cursor;
658 Inserted : out Boolean)
660 function New_Node return Node_Access;
661 pragma Inline (New_Node);
663 procedure Insert_Post is
664 new Key_Ops.Generic_Insert_Post (New_Node);
666 procedure Insert_Sans_Hint is
667 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
673 function New_Node return Node_Access is
674 Node : Node_Access := new Node_Type;
677 Node.Key := new Key_Type'(Key);
678 Node.Element := new Element_Type'(New_Item);
684 -- On exception, deallocate key and elem
686 Free (Node); -- Note that Free deallocates key and elem too
690 -- Start of processing for Insert
699 Position.Container := Container'Unrestricted_Access;
703 (Container : in out Map;
705 New_Item : Element_Type)
708 pragma Unreferenced (Position);
713 Insert (Container, Key, New_Item, Position, Inserted);
716 raise Constraint_Error with "key already in map";
724 function Is_Empty (Container : Map) return Boolean is
726 return Container.Tree.Length = 0;
729 ------------------------
730 -- Is_Equal_Node_Node --
731 ------------------------
733 function Is_Equal_Node_Node
734 (L, R : Node_Access) return Boolean is
736 if L.Key.all < R.Key.all then
739 elsif R.Key.all < L.Key.all then
743 return L.Element.all = R.Element.all;
745 end Is_Equal_Node_Node;
747 -------------------------
748 -- Is_Greater_Key_Node --
749 -------------------------
751 function Is_Greater_Key_Node
753 Right : Node_Access) return Boolean
756 -- k > node same as node < k
758 return Right.Key.all < Left;
759 end Is_Greater_Key_Node;
761 ----------------------
762 -- Is_Less_Key_Node --
763 ----------------------
765 function Is_Less_Key_Node
767 Right : Node_Access) return Boolean is
769 return Left < Right.Key.all;
770 end Is_Less_Key_Node;
778 Process : not null access procedure (Position : Cursor))
780 procedure Process_Node (Node : Node_Access);
781 pragma Inline (Process_Node);
783 procedure Local_Iterate is
784 new Tree_Operations.Generic_Iteration (Process_Node);
790 procedure Process_Node (Node : Node_Access) is
792 Process (Cursor'(Container'Unrestricted_Access, Node));
795 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
797 -- Start of processing for Iterate
803 Local_Iterate (Container.Tree);
817 function Key (Position : Cursor) return Key_Type is
819 if Position.Node = null then
820 raise Constraint_Error with
821 "Position cursor of function Key equals No_Element";
824 if Position.Node.Key = null then
825 raise Program_Error with
826 "Position cursor of function Key is bad";
829 pragma Assert (Vet (Position.Container.Tree, Position.Node),
830 "Position cursor of function Key is bad");
832 return Position.Node.Key.all;
839 function Last (Container : Map) return Cursor is
840 T : Tree_Type renames Container.Tree;
843 if T.Last = null then
847 return Cursor'(Container'Unrestricted_Access, T.Last);
854 function Last_Element (Container : Map) return Element_Type is
855 T : Tree_Type renames Container.Tree;
858 if T.Last = null then
859 raise Constraint_Error with "map is empty";
862 return T.Last.Element.all;
869 function Last_Key (Container : Map) return Key_Type is
870 T : Tree_Type renames Container.Tree;
873 if T.Last = null then
874 raise Constraint_Error with "map is empty";
877 return T.Last.Key.all;
884 function Left (Node : Node_Access) return Node_Access is
893 function Length (Container : Map) return Count_Type is
895 return Container.Tree.Length;
903 new Tree_Operations.Generic_Move (Clear);
905 procedure Move (Target : in out Map; Source : in out Map) is
907 Move (Target => Target.Tree, Source => Source.Tree);
914 function Next (Position : Cursor) return Cursor is
916 if Position = No_Element then
920 pragma Assert (Position.Node /= null);
921 pragma Assert (Position.Node.Key /= null);
922 pragma Assert (Position.Node.Element /= null);
923 pragma Assert (Vet (Position.Container.Tree, Position.Node),
924 "Position cursor of Next is bad");
927 Node : constant Node_Access :=
928 Tree_Operations.Next (Position.Node);
934 return Cursor'(Position.Container, Node);
939 procedure Next (Position : in out Cursor) is
941 Position := Next (Position);
948 function Parent (Node : Node_Access) return Node_Access is
957 function Previous (Position : Cursor) return Cursor is
959 if Position = No_Element then
963 pragma Assert (Position.Node /= null);
964 pragma Assert (Position.Node.Key /= null);
965 pragma Assert (Position.Node.Element /= null);
966 pragma Assert (Vet (Position.Container.Tree, Position.Node),
967 "Position cursor of Previous is bad");
970 Node : constant Node_Access :=
971 Tree_Operations.Previous (Position.Node);
978 return Cursor'(Position.Container, Node);
982 procedure Previous (Position : in out Cursor) is
984 Position := Previous (Position);
991 procedure Query_Element
993 Process : not null access procedure (Key : Key_Type;
994 Element : Element_Type))
997 if Position.Node = null then
998 raise Constraint_Error with
999 "Position cursor of Query_Element equals No_Element";
1002 if Position.Node.Key = null
1003 or else Position.Node.Element = null
1005 raise Program_Error with
1006 "Position cursor of Query_Element is bad";
1009 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1010 "Position cursor of Query_Element is bad");
1013 T : Tree_Type renames Position.Container.Tree;
1015 B : Natural renames T.Busy;
1016 L : Natural renames T.Lock;
1023 K : Key_Type renames Position.Node.Key.all;
1024 E : Element_Type renames Position.Node.Element.all;
1045 (Stream : not null access Root_Stream_Type'Class;
1046 Container : out Map)
1049 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1050 pragma Inline (Read_Node);
1053 new Tree_Operations.Generic_Read (Clear, Read_Node);
1060 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1062 Node : Node_Access := new Node_Type;
1064 Node.Key := new Key_Type'(Key_Type'Input (Stream));
1065 Node.Element := new Element_Type'(Element_Type'Input (Stream));
1069 Free (Node); -- Note that Free deallocates key and elem too
1073 -- Start of processing for Read
1076 Read (Stream, Container.Tree);
1080 (Stream : not null access Root_Stream_Type'Class;
1084 raise Program_Error with "attempt to stream map cursor";
1092 (Container : in out Map;
1094 New_Item : Element_Type)
1096 Node : constant Node_Access :=
1097 Key_Ops.Find (Container.Tree, Key);
1104 raise Constraint_Error with "key not in map";
1107 if Container.Tree.Lock > 0 then
1108 raise Program_Error with
1109 "attempt to tamper with cursors (map is locked)";
1115 Node.Key := new Key_Type'(Key);
1118 Node.Element := new Element_Type'(New_Item);
1129 ---------------------
1130 -- Replace_Element --
1131 ---------------------
1133 procedure Replace_Element
1134 (Container : in out Map;
1136 New_Item : Element_Type)
1139 if Position.Node = null then
1140 raise Constraint_Error with
1141 "Position cursor of Replace_Element equals No_Element";
1144 if Position.Node.Key = null
1145 or else Position.Node.Element = null
1147 raise Program_Error with
1148 "Position cursor of Replace_Element is bad";
1151 if Position.Container /= Container'Unrestricted_Access then
1152 raise Program_Error with
1153 "Position cursor of Replace_Element designates wrong map";
1156 if Container.Tree.Lock > 0 then
1157 raise Program_Error with
1158 "attempt to tamper with cursors (map is locked)";
1161 pragma Assert (Vet (Container.Tree, Position.Node),
1162 "Position cursor of Replace_Element is bad");
1165 X : Element_Access := Position.Node.Element;
1168 Position.Node.Element := new Element_Type'(New_Item);
1171 end Replace_Element;
1173 ---------------------
1174 -- Reverse_Iterate --
1175 ---------------------
1177 procedure Reverse_Iterate
1179 Process : not null access procedure (Position : Cursor))
1181 procedure Process_Node (Node : Node_Access);
1182 pragma Inline (Process_Node);
1184 procedure Local_Reverse_Iterate is
1185 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1191 procedure Process_Node (Node : Node_Access) is
1193 Process (Cursor'(Container'Unrestricted_Access, Node));
1196 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
1198 -- Start of processing for Reverse_Iterate
1204 Local_Reverse_Iterate (Container.Tree);
1212 end Reverse_Iterate;
1218 function Right (Node : Node_Access) return Node_Access is
1227 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1229 Node.Color := Color;
1236 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1245 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1247 Node.Parent := Parent;
1254 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1256 Node.Right := Right;
1259 --------------------
1260 -- Update_Element --
1261 --------------------
1263 procedure Update_Element
1264 (Container : in out Map;
1266 Process : not null access procedure (Key : Key_Type;
1267 Element : in out Element_Type))
1270 if Position.Node = null then
1271 raise Constraint_Error with
1272 "Position cursor of Update_Element equals No_Element";
1275 if Position.Node.Key = null
1276 or else Position.Node.Element = null
1278 raise Program_Error with
1279 "Position cursor of Update_Element is bad";
1282 if Position.Container /= Container'Unrestricted_Access then
1283 raise Program_Error with
1284 "Position cursor of Update_Element designates wrong map";
1287 pragma Assert (Vet (Container.Tree, Position.Node),
1288 "Position cursor of Update_Element is bad");
1291 T : Tree_Type renames Position.Container.Tree;
1293 B : Natural renames T.Busy;
1294 L : Natural renames T.Lock;
1301 K : Key_Type renames Position.Node.Key.all;
1302 E : Element_Type renames Position.Node.Element.all;
1324 (Stream : not null access Root_Stream_Type'Class;
1327 procedure Write_Node
1328 (Stream : not null access Root_Stream_Type'Class;
1329 Node : Node_Access);
1330 pragma Inline (Write_Node);
1333 new Tree_Operations.Generic_Write (Write_Node);
1339 procedure Write_Node
1340 (Stream : not null access Root_Stream_Type'Class;
1344 Key_Type'Output (Stream, Node.Key.all);
1345 Element_Type'Output (Stream, Node.Element.all);
1348 -- Start of processing for Write
1351 Write (Stream, Container.Tree);
1355 (Stream : not null access Root_Stream_Type'Class;
1359 raise Program_Error with "attempt to stream map cursor";
1362 end Ada.Containers.Indefinite_Ordered_Maps;