1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
9 -- Copyright (C) 2004-2007, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- This unit was originally developed by Matthew J Heaney. --
30 ------------------------------------------------------------------------------
32 with Ada.Unchecked_Deallocation;
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 package body Ada.Containers.Indefinite_Ordered_Maps is
42 -----------------------------
43 -- Node Access Subprograms --
44 -----------------------------
46 -- These subprograms provide a functional interface to access fields
47 -- of a node, and a procedural interface for modifying these values.
49 function Color (Node : Node_Access) return Color_Type;
50 pragma Inline (Color);
52 function Left (Node : Node_Access) return Node_Access;
55 function Parent (Node : Node_Access) return Node_Access;
56 pragma Inline (Parent);
58 function Right (Node : Node_Access) return Node_Access;
59 pragma Inline (Right);
61 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
62 pragma Inline (Set_Parent);
64 procedure Set_Left (Node : Node_Access; Left : Node_Access);
65 pragma Inline (Set_Left);
67 procedure Set_Right (Node : Node_Access; Right : Node_Access);
68 pragma Inline (Set_Right);
70 procedure Set_Color (Node : Node_Access; Color : Color_Type);
71 pragma Inline (Set_Color);
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 function Copy_Node (Source : Node_Access) return Node_Access;
78 pragma Inline (Copy_Node);
80 procedure Free (X : in out Node_Access);
82 function Is_Equal_Node_Node
83 (L, R : Node_Access) return Boolean;
84 pragma Inline (Is_Equal_Node_Node);
86 function Is_Greater_Key_Node
88 Right : Node_Access) return Boolean;
89 pragma Inline (Is_Greater_Key_Node);
91 function Is_Less_Key_Node
93 Right : Node_Access) return Boolean;
94 pragma Inline (Is_Less_Key_Node);
96 --------------------------
97 -- Local Instantiations --
98 --------------------------
100 package Tree_Operations is
101 new Red_Black_Trees.Generic_Operations (Tree_Types);
103 procedure Delete_Tree is
104 new Tree_Operations.Generic_Delete_Tree (Free);
106 function Copy_Tree is
107 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
112 new Red_Black_Trees.Generic_Keys
113 (Tree_Operations => Tree_Operations,
114 Key_Type => Key_Type,
115 Is_Less_Key_Node => Is_Less_Key_Node,
116 Is_Greater_Key_Node => Is_Greater_Key_Node);
118 procedure Free_Key is
119 new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
121 procedure Free_Element is
122 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
125 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
131 function "<" (Left, Right : Cursor) return Boolean is
133 if Left.Node = null then
134 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
137 if Right.Node = null then
138 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
141 if Left.Node.Key = null then
142 raise Program_Error with "Left cursor in ""<"" is bad";
145 if Right.Node.Key = null then
146 raise Program_Error with "Right cursor in ""<"" is bad";
149 pragma Assert (Vet (Left.Container.Tree, Left.Node),
150 "Left cursor in ""<"" is bad");
152 pragma Assert (Vet (Right.Container.Tree, Right.Node),
153 "Right cursor in ""<"" is bad");
155 return Left.Node.Key.all < Right.Node.Key.all;
158 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
160 if Left.Node = null then
161 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
164 if Left.Node.Key = null then
165 raise Program_Error with "Left cursor in ""<"" is bad";
168 pragma Assert (Vet (Left.Container.Tree, Left.Node),
169 "Left cursor in ""<"" is bad");
171 return Left.Node.Key.all < Right;
174 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
176 if Right.Node = null then
177 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
180 if Right.Node.Key = null then
181 raise Program_Error with "Right cursor in ""<"" is bad";
184 pragma Assert (Vet (Right.Container.Tree, Right.Node),
185 "Right cursor in ""<"" is bad");
187 return Left < Right.Node.Key.all;
194 function "=" (Left, Right : Map) return Boolean is
196 return Is_Equal (Left.Tree, Right.Tree);
203 function ">" (Left, Right : Cursor) return Boolean is
205 if Left.Node = null then
206 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
209 if Right.Node = null then
210 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
213 if Left.Node.Key = null then
214 raise Program_Error with "Left cursor in ""<"" is bad";
217 if Right.Node.Key = null then
218 raise Program_Error with "Right cursor in ""<"" is bad";
221 pragma Assert (Vet (Left.Container.Tree, Left.Node),
222 "Left cursor in "">"" is bad");
224 pragma Assert (Vet (Right.Container.Tree, Right.Node),
225 "Right cursor in "">"" is bad");
227 return Right.Node.Key.all < Left.Node.Key.all;
230 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
232 if Left.Node = null then
233 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
236 if Left.Node.Key = null then
237 raise Program_Error with "Left cursor in ""<"" is bad";
240 pragma Assert (Vet (Left.Container.Tree, Left.Node),
241 "Left cursor in "">"" is bad");
243 return Right < Left.Node.Key.all;
246 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
248 if Right.Node = null then
249 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
252 if Right.Node.Key = null then
253 raise Program_Error with "Right cursor in ""<"" is bad";
256 pragma Assert (Vet (Right.Container.Tree, Right.Node),
257 "Right cursor in "">"" is bad");
259 return Right.Node.Key.all < Left;
267 new Tree_Operations.Generic_Adjust (Copy_Tree);
269 procedure Adjust (Container : in out Map) is
271 Adjust (Container.Tree);
278 function Ceiling (Container : Map; Key : Key_Type) return Cursor is
279 Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
286 return Cursor'(Container'Unrestricted_Access, Node);
294 new Tree_Operations.Generic_Clear (Delete_Tree);
296 procedure Clear (Container : in out Map) is
298 Clear (Container.Tree);
305 function Color (Node : Node_Access) return Color_Type is
314 function Contains (Container : Map; Key : Key_Type) return Boolean is
316 return Find (Container, Key) /= No_Element;
323 function Copy_Node (Source : Node_Access) return Node_Access is
324 K : Key_Access := new Key_Type'(Source.Key.all);
327 E := new Element_Type'(Source.Element.all);
329 return new Node_Type'(Parent => null,
332 Color => Source.Color,
347 (Container : in out Map;
348 Position : in out Cursor)
351 if Position.Node = null then
352 raise Constraint_Error with
353 "Position cursor of Delete equals No_Element";
356 if Position.Node.Key = null
357 or else Position.Node.Element = null
359 raise Program_Error with "Position cursor of Delete is bad";
362 if Position.Container /= Container'Unrestricted_Access then
363 raise Program_Error with
364 "Position cursor of Delete designates wrong map";
367 pragma Assert (Vet (Container.Tree, Position.Node),
368 "Position cursor of Delete is bad");
370 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
371 Free (Position.Node);
373 Position.Container := null;
376 procedure Delete (Container : in out Map; Key : Key_Type) is
377 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
381 raise Constraint_Error with "key not in map";
384 Delete_Node_Sans_Free (Container.Tree, X);
392 procedure Delete_First (Container : in out Map) is
393 X : Node_Access := Container.Tree.First;
397 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
406 procedure Delete_Last (Container : in out Map) is
407 X : Node_Access := Container.Tree.Last;
411 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
420 function Element (Position : Cursor) return Element_Type is
422 if Position.Node = null then
423 raise Constraint_Error with
424 "Position cursor of function Element equals No_Element";
427 if Position.Node.Element = null then
428 raise Program_Error with
429 "Position cursor of function Element is bad";
432 pragma Assert (Vet (Position.Container.Tree, Position.Node),
433 "Position cursor of function Element is bad");
435 return Position.Node.Element.all;
438 function Element (Container : Map; Key : Key_Type) return Element_Type is
439 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
443 raise Constraint_Error with "key not in map";
446 return Node.Element.all;
449 ---------------------
450 -- Equivalent_Keys --
451 ---------------------
453 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
468 procedure Exclude (Container : in out Map; Key : Key_Type) is
469 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
473 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
482 function Find (Container : Map; Key : Key_Type) return Cursor is
483 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
490 return Cursor'(Container'Unrestricted_Access, Node);
497 function First (Container : Map) return Cursor is
498 T : Tree_Type renames Container.Tree;
501 if T.First = null then
505 return Cursor'(Container'Unrestricted_Access, T.First);
512 function First_Element (Container : Map) return Element_Type is
513 T : Tree_Type renames Container.Tree;
516 if T.First = null then
517 raise Constraint_Error with "map is empty";
520 return T.First.Element.all;
527 function First_Key (Container : Map) return Key_Type is
528 T : Tree_Type renames Container.Tree;
531 if T.First = null then
532 raise Constraint_Error with "map is empty";
535 return T.First.Key.all;
542 function Floor (Container : Map; Key : Key_Type) return Cursor is
543 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
550 return Cursor'(Container'Unrestricted_Access, Node);
557 procedure Free (X : in out Node_Access) is
558 procedure Deallocate is
559 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
577 Free_Element (X.Element);
588 Free_Element (X.Element);
604 function Has_Element (Position : Cursor) return Boolean is
606 return Position /= No_Element;
614 (Container : in out Map;
616 New_Item : Element_Type)
625 Insert (Container, Key, New_Item, Position, Inserted);
628 if Container.Tree.Lock > 0 then
629 raise Program_Error with
630 "attempt to tamper with cursors (map is locked)";
633 K := Position.Node.Key;
634 E := Position.Node.Element;
636 Position.Node.Key := new Key_Type'(Key);
639 Position.Node.Element := new Element_Type'(New_Item);
656 (Container : in out Map;
658 New_Item : Element_Type;
659 Position : out Cursor;
660 Inserted : out Boolean)
662 function New_Node return Node_Access;
663 pragma Inline (New_Node);
665 procedure Insert_Post is
666 new Key_Ops.Generic_Insert_Post (New_Node);
668 procedure Insert_Sans_Hint is
669 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
675 function New_Node return Node_Access is
676 Node : Node_Access := new Node_Type;
679 Node.Key := new Key_Type'(Key);
680 Node.Element := new Element_Type'(New_Item);
686 -- On exception, deallocate key and elem
688 Free (Node); -- Note that Free deallocates key and elem too
692 -- Start of processing for Insert
701 Position.Container := Container'Unrestricted_Access;
705 (Container : in out Map;
707 New_Item : Element_Type)
710 pragma Unreferenced (Position);
715 Insert (Container, Key, New_Item, Position, Inserted);
718 raise Constraint_Error with "key already in map";
726 function Is_Empty (Container : Map) return Boolean is
728 return Container.Tree.Length = 0;
731 ------------------------
732 -- Is_Equal_Node_Node --
733 ------------------------
735 function Is_Equal_Node_Node
736 (L, R : Node_Access) return Boolean is
738 if L.Key.all < R.Key.all then
741 elsif R.Key.all < L.Key.all then
745 return L.Element.all = R.Element.all;
747 end Is_Equal_Node_Node;
749 -------------------------
750 -- Is_Greater_Key_Node --
751 -------------------------
753 function Is_Greater_Key_Node
755 Right : Node_Access) return Boolean
758 -- k > node same as node < k
760 return Right.Key.all < Left;
761 end Is_Greater_Key_Node;
763 ----------------------
764 -- Is_Less_Key_Node --
765 ----------------------
767 function Is_Less_Key_Node
769 Right : Node_Access) return Boolean is
771 return Left < Right.Key.all;
772 end Is_Less_Key_Node;
780 Process : not null access procedure (Position : Cursor))
782 procedure Process_Node (Node : Node_Access);
783 pragma Inline (Process_Node);
785 procedure Local_Iterate is
786 new Tree_Operations.Generic_Iteration (Process_Node);
792 procedure Process_Node (Node : Node_Access) is
794 Process (Cursor'(Container'Unrestricted_Access, Node));
797 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
799 -- Start of processing for Iterate
805 Local_Iterate (Container.Tree);
819 function Key (Position : Cursor) return Key_Type is
821 if Position.Node = null then
822 raise Constraint_Error with
823 "Position cursor of function Key equals No_Element";
826 if Position.Node.Key = null then
827 raise Program_Error with
828 "Position cursor of function Key is bad";
831 pragma Assert (Vet (Position.Container.Tree, Position.Node),
832 "Position cursor of function Key is bad");
834 return Position.Node.Key.all;
841 function Last (Container : Map) return Cursor is
842 T : Tree_Type renames Container.Tree;
845 if T.Last = null then
849 return Cursor'(Container'Unrestricted_Access, T.Last);
856 function Last_Element (Container : Map) return Element_Type is
857 T : Tree_Type renames Container.Tree;
860 if T.Last = null then
861 raise Constraint_Error with "map is empty";
864 return T.Last.Element.all;
871 function Last_Key (Container : Map) return Key_Type is
872 T : Tree_Type renames Container.Tree;
875 if T.Last = null then
876 raise Constraint_Error with "map is empty";
879 return T.Last.Key.all;
886 function Left (Node : Node_Access) return Node_Access is
895 function Length (Container : Map) return Count_Type is
897 return Container.Tree.Length;
905 new Tree_Operations.Generic_Move (Clear);
907 procedure Move (Target : in out Map; Source : in out Map) is
909 Move (Target => Target.Tree, Source => Source.Tree);
916 function Next (Position : Cursor) return Cursor is
918 if Position = No_Element then
922 pragma Assert (Position.Node /= null);
923 pragma Assert (Position.Node.Key /= null);
924 pragma Assert (Position.Node.Element /= null);
925 pragma Assert (Vet (Position.Container.Tree, Position.Node),
926 "Position cursor of Next is bad");
929 Node : constant Node_Access :=
930 Tree_Operations.Next (Position.Node);
936 return Cursor'(Position.Container, Node);
941 procedure Next (Position : in out Cursor) is
943 Position := Next (Position);
950 function Parent (Node : Node_Access) return Node_Access is
959 function Previous (Position : Cursor) return Cursor is
961 if Position = No_Element then
965 pragma Assert (Position.Node /= null);
966 pragma Assert (Position.Node.Key /= null);
967 pragma Assert (Position.Node.Element /= null);
968 pragma Assert (Vet (Position.Container.Tree, Position.Node),
969 "Position cursor of Previous is bad");
972 Node : constant Node_Access :=
973 Tree_Operations.Previous (Position.Node);
980 return Cursor'(Position.Container, Node);
984 procedure Previous (Position : in out Cursor) is
986 Position := Previous (Position);
993 procedure Query_Element
995 Process : not null access procedure (Key : Key_Type;
996 Element : Element_Type))
999 if Position.Node = null then
1000 raise Constraint_Error with
1001 "Position cursor of Query_Element equals No_Element";
1004 if Position.Node.Key = null
1005 or else Position.Node.Element = null
1007 raise Program_Error with
1008 "Position cursor of Query_Element is bad";
1011 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1012 "Position cursor of Query_Element is bad");
1015 T : Tree_Type renames Position.Container.Tree;
1017 B : Natural renames T.Busy;
1018 L : Natural renames T.Lock;
1025 K : Key_Type renames Position.Node.Key.all;
1026 E : Element_Type renames Position.Node.Element.all;
1047 (Stream : not null access Root_Stream_Type'Class;
1048 Container : out Map)
1051 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1052 pragma Inline (Read_Node);
1055 new Tree_Operations.Generic_Read (Clear, Read_Node);
1062 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1064 Node : Node_Access := new Node_Type;
1066 Node.Key := new Key_Type'(Key_Type'Input (Stream));
1067 Node.Element := new Element_Type'(Element_Type'Input (Stream));
1071 Free (Node); -- Note that Free deallocates key and elem too
1075 -- Start of processing for Read
1078 Read (Stream, Container.Tree);
1082 (Stream : not null access Root_Stream_Type'Class;
1086 raise Program_Error with "attempt to stream map cursor";
1094 (Container : in out Map;
1096 New_Item : Element_Type)
1098 Node : constant Node_Access :=
1099 Key_Ops.Find (Container.Tree, Key);
1106 raise Constraint_Error with "key not in map";
1109 if Container.Tree.Lock > 0 then
1110 raise Program_Error with
1111 "attempt to tamper with cursors (map is locked)";
1117 Node.Key := new Key_Type'(Key);
1120 Node.Element := new Element_Type'(New_Item);
1131 ---------------------
1132 -- Replace_Element --
1133 ---------------------
1135 procedure Replace_Element
1136 (Container : in out Map;
1138 New_Item : Element_Type)
1141 if Position.Node = null then
1142 raise Constraint_Error with
1143 "Position cursor of Replace_Element equals No_Element";
1146 if Position.Node.Key = null
1147 or else Position.Node.Element = null
1149 raise Program_Error with
1150 "Position cursor of Replace_Element is bad";
1153 if Position.Container /= Container'Unrestricted_Access then
1154 raise Program_Error with
1155 "Position cursor of Replace_Element designates wrong map";
1158 if Container.Tree.Lock > 0 then
1159 raise Program_Error with
1160 "attempt to tamper with cursors (map is locked)";
1163 pragma Assert (Vet (Container.Tree, Position.Node),
1164 "Position cursor of Replace_Element is bad");
1167 X : Element_Access := Position.Node.Element;
1170 Position.Node.Element := new Element_Type'(New_Item);
1173 end Replace_Element;
1175 ---------------------
1176 -- Reverse_Iterate --
1177 ---------------------
1179 procedure Reverse_Iterate
1181 Process : not null access procedure (Position : Cursor))
1183 procedure Process_Node (Node : Node_Access);
1184 pragma Inline (Process_Node);
1186 procedure Local_Reverse_Iterate is
1187 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1193 procedure Process_Node (Node : Node_Access) is
1195 Process (Cursor'(Container'Unrestricted_Access, Node));
1198 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
1200 -- Start of processing for Reverse_Iterate
1206 Local_Reverse_Iterate (Container.Tree);
1214 end Reverse_Iterate;
1220 function Right (Node : Node_Access) return Node_Access is
1229 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1231 Node.Color := Color;
1238 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1247 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1249 Node.Parent := Parent;
1256 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1258 Node.Right := Right;
1261 --------------------
1262 -- Update_Element --
1263 --------------------
1265 procedure Update_Element
1266 (Container : in out Map;
1268 Process : not null access procedure (Key : Key_Type;
1269 Element : in out Element_Type))
1272 if Position.Node = null then
1273 raise Constraint_Error with
1274 "Position cursor of Update_Element equals No_Element";
1277 if Position.Node.Key = null
1278 or else Position.Node.Element = null
1280 raise Program_Error with
1281 "Position cursor of Update_Element is bad";
1284 if Position.Container /= Container'Unrestricted_Access then
1285 raise Program_Error with
1286 "Position cursor of Update_Element designates wrong map";
1289 pragma Assert (Vet (Container.Tree, Position.Node),
1290 "Position cursor of Update_Element is bad");
1293 T : Tree_Type renames Position.Container.Tree;
1295 B : Natural renames T.Busy;
1296 L : Natural renames T.Lock;
1303 K : Key_Type renames Position.Node.Key.all;
1304 E : Element_Type renames Position.Node.Element.all;
1326 (Stream : not null access Root_Stream_Type'Class;
1329 procedure Write_Node
1330 (Stream : not null access Root_Stream_Type'Class;
1331 Node : Node_Access);
1332 pragma Inline (Write_Node);
1335 new Tree_Operations.Generic_Write (Write_Node);
1341 procedure Write_Node
1342 (Stream : not null access Root_Stream_Type'Class;
1346 Key_Type'Output (Stream, Node.Key.all);
1347 Element_Type'Output (Stream, Node.Element.all);
1350 -- Start of processing for Write
1353 Write (Stream, Container.Tree);
1357 (Stream : not null access Root_Stream_Type'Class;
1361 raise Program_Error with "attempt to stream map cursor";
1364 end Ada.Containers.Indefinite_Ordered_Maps;