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-2007, 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)
711 pragma Unreferenced (Position);
716 Insert (Container, Key, New_Item, Position, Inserted);
719 raise Constraint_Error with "key already in map";
727 function Is_Empty (Container : Map) return Boolean is
729 return Container.Tree.Length = 0;
732 ------------------------
733 -- Is_Equal_Node_Node --
734 ------------------------
736 function Is_Equal_Node_Node
737 (L, R : Node_Access) return Boolean is
739 if L.Key.all < R.Key.all then
742 elsif R.Key.all < L.Key.all then
746 return L.Element.all = R.Element.all;
748 end Is_Equal_Node_Node;
750 -------------------------
751 -- Is_Greater_Key_Node --
752 -------------------------
754 function Is_Greater_Key_Node
756 Right : Node_Access) return Boolean
759 -- k > node same as node < k
761 return Right.Key.all < Left;
762 end Is_Greater_Key_Node;
764 ----------------------
765 -- Is_Less_Key_Node --
766 ----------------------
768 function Is_Less_Key_Node
770 Right : Node_Access) return Boolean is
772 return Left < Right.Key.all;
773 end Is_Less_Key_Node;
781 Process : not null access procedure (Position : Cursor))
783 procedure Process_Node (Node : Node_Access);
784 pragma Inline (Process_Node);
786 procedure Local_Iterate is
787 new Tree_Operations.Generic_Iteration (Process_Node);
793 procedure Process_Node (Node : Node_Access) is
795 Process (Cursor'(Container'Unrestricted_Access, Node));
798 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
800 -- Start of processing for Iterate
806 Local_Iterate (Container.Tree);
820 function Key (Position : Cursor) return Key_Type is
822 if Position.Node = null then
823 raise Constraint_Error with
824 "Position cursor of function Key equals No_Element";
827 if Position.Node.Key = null then
828 raise Program_Error with
829 "Position cursor of function Key is bad";
832 pragma Assert (Vet (Position.Container.Tree, Position.Node),
833 "Position cursor of function Key is bad");
835 return Position.Node.Key.all;
842 function Last (Container : Map) return Cursor is
843 T : Tree_Type renames Container.Tree;
846 if T.Last = null then
850 return Cursor'(Container'Unrestricted_Access, T.Last);
857 function Last_Element (Container : Map) return Element_Type is
858 T : Tree_Type renames Container.Tree;
861 if T.Last = null then
862 raise Constraint_Error with "map is empty";
865 return T.Last.Element.all;
872 function Last_Key (Container : Map) return Key_Type is
873 T : Tree_Type renames Container.Tree;
876 if T.Last = null then
877 raise Constraint_Error with "map is empty";
880 return T.Last.Key.all;
887 function Left (Node : Node_Access) return Node_Access is
896 function Length (Container : Map) return Count_Type is
898 return Container.Tree.Length;
906 new Tree_Operations.Generic_Move (Clear);
908 procedure Move (Target : in out Map; Source : in out Map) is
910 Move (Target => Target.Tree, Source => Source.Tree);
917 function Next (Position : Cursor) return Cursor is
919 if Position = No_Element then
923 pragma Assert (Position.Node /= null);
924 pragma Assert (Position.Node.Key /= null);
925 pragma Assert (Position.Node.Element /= null);
926 pragma Assert (Vet (Position.Container.Tree, Position.Node),
927 "Position cursor of Next is bad");
930 Node : constant Node_Access :=
931 Tree_Operations.Next (Position.Node);
937 return Cursor'(Position.Container, Node);
942 procedure Next (Position : in out Cursor) is
944 Position := Next (Position);
951 function Parent (Node : Node_Access) return Node_Access is
960 function Previous (Position : Cursor) return Cursor is
962 if Position = No_Element then
966 pragma Assert (Position.Node /= null);
967 pragma Assert (Position.Node.Key /= null);
968 pragma Assert (Position.Node.Element /= null);
969 pragma Assert (Vet (Position.Container.Tree, Position.Node),
970 "Position cursor of Previous is bad");
973 Node : constant Node_Access :=
974 Tree_Operations.Previous (Position.Node);
981 return Cursor'(Position.Container, Node);
985 procedure Previous (Position : in out Cursor) is
987 Position := Previous (Position);
994 procedure Query_Element
996 Process : not null access procedure (Key : Key_Type;
997 Element : Element_Type))
1000 if Position.Node = null then
1001 raise Constraint_Error with
1002 "Position cursor of Query_Element equals No_Element";
1005 if Position.Node.Key = null
1006 or else Position.Node.Element = null
1008 raise Program_Error with
1009 "Position cursor of Query_Element is bad";
1012 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1013 "Position cursor of Query_Element is bad");
1016 T : Tree_Type renames Position.Container.Tree;
1018 B : Natural renames T.Busy;
1019 L : Natural renames T.Lock;
1026 K : Key_Type renames Position.Node.Key.all;
1027 E : Element_Type renames Position.Node.Element.all;
1048 (Stream : not null access Root_Stream_Type'Class;
1049 Container : out Map)
1052 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1053 pragma Inline (Read_Node);
1056 new Tree_Operations.Generic_Read (Clear, Read_Node);
1063 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1065 Node : Node_Access := new Node_Type;
1067 Node.Key := new Key_Type'(Key_Type'Input (Stream));
1068 Node.Element := new Element_Type'(Element_Type'Input (Stream));
1072 Free (Node); -- Note that Free deallocates key and elem too
1076 -- Start of processing for Read
1079 Read (Stream, Container.Tree);
1083 (Stream : not null access Root_Stream_Type'Class;
1087 raise Program_Error with "attempt to stream map cursor";
1095 (Container : in out Map;
1097 New_Item : Element_Type)
1099 Node : constant Node_Access :=
1100 Key_Ops.Find (Container.Tree, Key);
1107 raise Constraint_Error with "key not in map";
1110 if Container.Tree.Lock > 0 then
1111 raise Program_Error with
1112 "attempt to tamper with cursors (map is locked)";
1118 Node.Key := new Key_Type'(Key);
1121 Node.Element := new Element_Type'(New_Item);
1132 ---------------------
1133 -- Replace_Element --
1134 ---------------------
1136 procedure Replace_Element
1137 (Container : in out Map;
1139 New_Item : Element_Type)
1142 if Position.Node = null then
1143 raise Constraint_Error with
1144 "Position cursor of Replace_Element equals No_Element";
1147 if Position.Node.Key = null
1148 or else Position.Node.Element = null
1150 raise Program_Error with
1151 "Position cursor of Replace_Element is bad";
1154 if Position.Container /= Container'Unrestricted_Access then
1155 raise Program_Error with
1156 "Position cursor of Replace_Element designates wrong map";
1159 if Container.Tree.Lock > 0 then
1160 raise Program_Error with
1161 "attempt to tamper with cursors (map is locked)";
1164 pragma Assert (Vet (Container.Tree, Position.Node),
1165 "Position cursor of Replace_Element is bad");
1168 X : Element_Access := Position.Node.Element;
1171 Position.Node.Element := new Element_Type'(New_Item);
1174 end Replace_Element;
1176 ---------------------
1177 -- Reverse_Iterate --
1178 ---------------------
1180 procedure Reverse_Iterate
1182 Process : not null access procedure (Position : Cursor))
1184 procedure Process_Node (Node : Node_Access);
1185 pragma Inline (Process_Node);
1187 procedure Local_Reverse_Iterate is
1188 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1194 procedure Process_Node (Node : Node_Access) is
1196 Process (Cursor'(Container'Unrestricted_Access, Node));
1199 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
1201 -- Start of processing for Reverse_Iterate
1207 Local_Reverse_Iterate (Container.Tree);
1215 end Reverse_Iterate;
1221 function Right (Node : Node_Access) return Node_Access is
1230 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1232 Node.Color := Color;
1239 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1248 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1250 Node.Parent := Parent;
1257 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1259 Node.Right := Right;
1262 --------------------
1263 -- Update_Element --
1264 --------------------
1266 procedure Update_Element
1267 (Container : in out Map;
1269 Process : not null access procedure (Key : Key_Type;
1270 Element : in out Element_Type))
1273 if Position.Node = null then
1274 raise Constraint_Error with
1275 "Position cursor of Update_Element equals No_Element";
1278 if Position.Node.Key = null
1279 or else Position.Node.Element = null
1281 raise Program_Error with
1282 "Position cursor of Update_Element is bad";
1285 if Position.Container /= Container'Unrestricted_Access then
1286 raise Program_Error with
1287 "Position cursor of Update_Element designates wrong map";
1290 pragma Assert (Vet (Container.Tree, Position.Node),
1291 "Position cursor of Update_Element is bad");
1294 T : Tree_Type renames Position.Container.Tree;
1296 B : Natural renames T.Busy;
1297 L : Natural renames T.Lock;
1304 K : Key_Type renames Position.Node.Key.all;
1305 E : Element_Type renames Position.Node.Element.all;
1327 (Stream : not null access Root_Stream_Type'Class;
1330 procedure Write_Node
1331 (Stream : not null access Root_Stream_Type'Class;
1332 Node : Node_Access);
1333 pragma Inline (Write_Node);
1336 new Tree_Operations.Generic_Write (Write_Node);
1342 procedure Write_Node
1343 (Stream : not null access Root_Stream_Type'Class;
1347 Key_Type'Output (Stream, Node.Key.all);
1348 Element_Type'Output (Stream, Node.Element.all);
1351 -- Start of processing for Write
1354 Write (Stream, Container.Tree);
1358 (Stream : not null access Root_Stream_Type'Class;
1362 raise Program_Error with "attempt to stream map cursor";
1365 end Ada.Containers.Indefinite_Ordered_Maps;