1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . --
6 -- I N D E F I N I T E _ O R D E R E D _ M A P S --
10 -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- This unit was originally developed by Matthew J Heaney. --
31 ------------------------------------------------------------------------------
33 with Ada.Unchecked_Deallocation;
35 with Ada.Containers.Red_Black_Trees.Generic_Operations;
36 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
38 with Ada.Containers.Red_Black_Trees.Generic_Keys;
39 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
41 package body Ada.Containers.Indefinite_Ordered_Maps is
43 -----------------------------
44 -- Node Access Subprograms --
45 -----------------------------
47 -- These subprograms provide a functional interface to access fields
48 -- of a node, and a procedural interface for modifying these values.
50 function Color (Node : Node_Access) return Color_Type;
51 pragma Inline (Color);
53 function Left (Node : Node_Access) return Node_Access;
56 function Parent (Node : Node_Access) return Node_Access;
57 pragma Inline (Parent);
59 function Right (Node : Node_Access) return Node_Access;
60 pragma Inline (Right);
62 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
63 pragma Inline (Set_Parent);
65 procedure Set_Left (Node : Node_Access; Left : Node_Access);
66 pragma Inline (Set_Left);
68 procedure Set_Right (Node : Node_Access; Right : Node_Access);
69 pragma Inline (Set_Right);
71 procedure Set_Color (Node : Node_Access; Color : Color_Type);
72 pragma Inline (Set_Color);
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 function Copy_Node (Source : Node_Access) return Node_Access;
79 pragma Inline (Copy_Node);
81 procedure Free (X : in out Node_Access);
83 function Is_Equal_Node_Node
84 (L, R : Node_Access) return Boolean;
85 pragma Inline (Is_Equal_Node_Node);
87 function Is_Greater_Key_Node
89 Right : Node_Access) return Boolean;
90 pragma Inline (Is_Greater_Key_Node);
92 function Is_Less_Key_Node
94 Right : Node_Access) return Boolean;
95 pragma Inline (Is_Less_Key_Node);
97 --------------------------
98 -- Local Instantiations --
99 --------------------------
101 package Tree_Operations is
102 new Red_Black_Trees.Generic_Operations (Tree_Types);
104 procedure Delete_Tree is
105 new Tree_Operations.Generic_Delete_Tree (Free);
107 function Copy_Tree is
108 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
113 new Red_Black_Trees.Generic_Keys
114 (Tree_Operations => Tree_Operations,
115 Key_Type => Key_Type,
116 Is_Less_Key_Node => Is_Less_Key_Node,
117 Is_Greater_Key_Node => Is_Greater_Key_Node);
119 procedure Free_Key is
120 new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
122 procedure Free_Element is
123 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
126 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
132 function "<" (Left, Right : Cursor) return Boolean is
134 if Left.Node = null then
135 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
138 if Right.Node = null then
139 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
142 if Left.Node.Key = null then
143 raise Program_Error with "Left cursor in ""<"" is bad";
146 if Right.Node.Key = null then
147 raise Program_Error with "Right cursor in ""<"" is bad";
150 pragma Assert (Vet (Left.Container.Tree, Left.Node),
151 "Left cursor in ""<"" is bad");
153 pragma Assert (Vet (Right.Container.Tree, Right.Node),
154 "Right cursor in ""<"" is bad");
156 return Left.Node.Key.all < Right.Node.Key.all;
159 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
161 if Left.Node = null then
162 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
165 if Left.Node.Key = null then
166 raise Program_Error with "Left cursor in ""<"" is bad";
169 pragma Assert (Vet (Left.Container.Tree, Left.Node),
170 "Left cursor in ""<"" is bad");
172 return Left.Node.Key.all < Right;
175 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
177 if Right.Node = null then
178 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
181 if Right.Node.Key = null then
182 raise Program_Error with "Right cursor in ""<"" is bad";
185 pragma Assert (Vet (Right.Container.Tree, Right.Node),
186 "Right cursor in ""<"" is bad");
188 return Left < Right.Node.Key.all;
195 function "=" (Left, Right : Map) return Boolean is
197 return Is_Equal (Left.Tree, Right.Tree);
204 function ">" (Left, Right : Cursor) return Boolean is
206 if Left.Node = null then
207 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
210 if Right.Node = null then
211 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
214 if Left.Node.Key = null then
215 raise Program_Error with "Left cursor in ""<"" is bad";
218 if Right.Node.Key = null then
219 raise Program_Error with "Right cursor in ""<"" is bad";
222 pragma Assert (Vet (Left.Container.Tree, Left.Node),
223 "Left cursor in "">"" is bad");
225 pragma Assert (Vet (Right.Container.Tree, Right.Node),
226 "Right cursor in "">"" is bad");
228 return Right.Node.Key.all < Left.Node.Key.all;
231 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
233 if Left.Node = null then
234 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
237 if Left.Node.Key = null then
238 raise Program_Error with "Left cursor in ""<"" is bad";
241 pragma Assert (Vet (Left.Container.Tree, Left.Node),
242 "Left cursor in "">"" is bad");
244 return Right < Left.Node.Key.all;
247 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
249 if Right.Node = null then
250 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
253 if Right.Node.Key = null then
254 raise Program_Error with "Right cursor in ""<"" is bad";
257 pragma Assert (Vet (Right.Container.Tree, Right.Node),
258 "Right cursor in "">"" is bad");
260 return Right.Node.Key.all < Left;
268 new Tree_Operations.Generic_Adjust (Copy_Tree);
270 procedure Adjust (Container : in out Map) is
272 Adjust (Container.Tree);
279 function Ceiling (Container : Map; Key : Key_Type) return Cursor is
280 Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
287 return Cursor'(Container'Unrestricted_Access, Node);
295 new Tree_Operations.Generic_Clear (Delete_Tree);
297 procedure Clear (Container : in out Map) is
299 Clear (Container.Tree);
306 function Color (Node : Node_Access) return Color_Type is
315 function Contains (Container : Map; Key : Key_Type) return Boolean is
317 return Find (Container, Key) /= No_Element;
324 function Copy_Node (Source : Node_Access) return Node_Access is
325 K : Key_Access := new Key_Type'(Source.Key.all);
328 E := new Element_Type'(Source.Element.all);
330 return new Node_Type'(Parent => null,
333 Color => Source.Color,
348 (Container : in out Map;
349 Position : in out Cursor)
352 if Position.Node = null then
353 raise Constraint_Error with
354 "Position cursor of Delete equals No_Element";
357 if Position.Node.Key = null
358 or else Position.Node.Element = null
360 raise Program_Error with "Position cursor of Delete is bad";
363 if Position.Container /= Container'Unrestricted_Access then
364 raise Program_Error with
365 "Position cursor of Delete designates wrong map";
368 pragma Assert (Vet (Container.Tree, Position.Node),
369 "Position cursor of Delete is bad");
371 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
372 Free (Position.Node);
374 Position.Container := null;
377 procedure Delete (Container : in out Map; Key : Key_Type) is
378 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
382 raise Constraint_Error with "key not in map";
385 Delete_Node_Sans_Free (Container.Tree, X);
393 procedure Delete_First (Container : in out Map) is
394 X : Node_Access := Container.Tree.First;
398 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
407 procedure Delete_Last (Container : in out Map) is
408 X : Node_Access := Container.Tree.Last;
412 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
421 function Element (Position : Cursor) return Element_Type is
423 if Position.Node = null then
424 raise Constraint_Error with
425 "Position cursor of function Element equals No_Element";
428 if Position.Node.Element = null then
429 raise Program_Error with
430 "Position cursor of function Element is bad";
433 pragma Assert (Vet (Position.Container.Tree, Position.Node),
434 "Position cursor of function Element is bad");
436 return Position.Node.Element.all;
439 function Element (Container : Map; Key : Key_Type) return Element_Type is
440 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
444 raise Constraint_Error with "key not in map";
447 return Node.Element.all;
450 ---------------------
451 -- Equivalent_Keys --
452 ---------------------
454 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
469 procedure Exclude (Container : in out Map; Key : Key_Type) is
470 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
474 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
483 function Find (Container : Map; Key : Key_Type) return Cursor is
484 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
491 return Cursor'(Container'Unrestricted_Access, Node);
498 function First (Container : Map) return Cursor is
499 T : Tree_Type renames Container.Tree;
502 if T.First = null then
506 return Cursor'(Container'Unrestricted_Access, T.First);
513 function First_Element (Container : Map) return Element_Type is
514 T : Tree_Type renames Container.Tree;
517 if T.First = null then
518 raise Constraint_Error with "map is empty";
521 return T.First.Element.all;
528 function First_Key (Container : Map) return Key_Type is
529 T : Tree_Type renames Container.Tree;
532 if T.First = null then
533 raise Constraint_Error with "map is empty";
536 return T.First.Key.all;
543 function Floor (Container : Map; Key : Key_Type) return Cursor is
544 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
551 return Cursor'(Container'Unrestricted_Access, Node);
558 procedure Free (X : in out Node_Access) is
559 procedure Deallocate is
560 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
578 Free_Element (X.Element);
589 Free_Element (X.Element);
605 function Has_Element (Position : Cursor) return Boolean is
607 return Position /= No_Element;
615 (Container : in out Map;
617 New_Item : Element_Type)
626 Insert (Container, Key, New_Item, Position, Inserted);
629 if Container.Tree.Lock > 0 then
630 raise Program_Error with
631 "attempt to tamper with cursors (map is locked)";
634 K := Position.Node.Key;
635 E := Position.Node.Element;
637 Position.Node.Key := new Key_Type'(Key);
640 Position.Node.Element := new Element_Type'(New_Item);
657 (Container : in out Map;
659 New_Item : Element_Type;
660 Position : out Cursor;
661 Inserted : out Boolean)
663 function New_Node return Node_Access;
664 pragma Inline (New_Node);
666 procedure Insert_Post is
667 new Key_Ops.Generic_Insert_Post (New_Node);
669 procedure Insert_Sans_Hint is
670 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
676 function New_Node return Node_Access is
677 Node : Node_Access := new Node_Type;
680 Node.Key := new Key_Type'(Key);
681 Node.Element := new Element_Type'(New_Item);
687 -- On exception, deallocate key and elem
689 Free (Node); -- Note that Free deallocates key and elem too
693 -- Start of processing for Insert
702 Position.Container := Container'Unrestricted_Access;
706 (Container : in out Map;
708 New_Item : Element_Type)
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;
1325 (Stream : not null access Root_Stream_Type'Class;
1328 procedure Write_Node
1329 (Stream : not null access Root_Stream_Type'Class;
1330 Node : Node_Access);
1331 pragma Inline (Write_Node);
1334 new Tree_Operations.Generic_Write (Write_Node);
1340 procedure Write_Node
1341 (Stream : not null access Root_Stream_Type'Class;
1345 Key_Type'Output (Stream, Node.Key.all);
1346 Element_Type'Output (Stream, Node.Element.all);
1349 -- Start of processing for Write
1352 Write (Stream, Container.Tree);
1356 (Stream : not null access Root_Stream_Type'Class;
1360 raise Program_Error with "attempt to stream map cursor";
1363 end Ada.Containers.Indefinite_Ordered_Maps;