1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . O R D E R E D _ M A P S --
9 -- Copyright (C) 2004-2010, 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.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 (L, R : Node_Access) return Boolean;
81 pragma Inline (Is_Equal_Node_Node);
83 function Is_Greater_Key_Node
85 Right : Node_Access) return Boolean;
86 pragma Inline (Is_Greater_Key_Node);
88 function Is_Less_Key_Node
90 Right : Node_Access) return Boolean;
91 pragma Inline (Is_Less_Key_Node);
93 --------------------------
94 -- Local Instantiations --
95 --------------------------
97 package Tree_Operations is
98 new Red_Black_Trees.Generic_Operations (Tree_Types);
100 procedure Delete_Tree is
101 new Tree_Operations.Generic_Delete_Tree (Free);
103 function Copy_Tree is
104 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
109 new Red_Black_Trees.Generic_Keys
110 (Tree_Operations => Tree_Operations,
111 Key_Type => Key_Type,
112 Is_Less_Key_Node => Is_Less_Key_Node,
113 Is_Greater_Key_Node => Is_Greater_Key_Node);
116 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
122 function "<" (Left, Right : Cursor) return Boolean is
124 if Left.Node = null then
125 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
128 if Right.Node = null then
129 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
132 pragma Assert (Vet (Left.Container.Tree, Left.Node),
133 "Left cursor of ""<"" is bad");
135 pragma Assert (Vet (Right.Container.Tree, Right.Node),
136 "Right cursor of ""<"" is bad");
138 return Left.Node.Key < Right.Node.Key;
141 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
143 if Left.Node = null then
144 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
147 pragma Assert (Vet (Left.Container.Tree, Left.Node),
148 "Left cursor of ""<"" is bad");
150 return Left.Node.Key < Right;
153 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
155 if Right.Node = null then
156 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
159 pragma Assert (Vet (Right.Container.Tree, Right.Node),
160 "Right cursor of ""<"" is bad");
162 return Left < Right.Node.Key;
169 function "=" (Left, Right : Map) return Boolean is
171 return Is_Equal (Left.Tree, Right.Tree);
178 function ">" (Left, Right : Cursor) return Boolean is
180 if Left.Node = null then
181 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
184 if Right.Node = null then
185 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
188 pragma Assert (Vet (Left.Container.Tree, Left.Node),
189 "Left cursor of "">"" is bad");
191 pragma Assert (Vet (Right.Container.Tree, Right.Node),
192 "Right cursor of "">"" is bad");
194 return Right.Node.Key < Left.Node.Key;
197 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
199 if Left.Node = null then
200 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
203 pragma Assert (Vet (Left.Container.Tree, Left.Node),
204 "Left cursor of "">"" is bad");
206 return Right < Left.Node.Key;
209 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
211 if Right.Node = null then
212 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
215 pragma Assert (Vet (Right.Container.Tree, Right.Node),
216 "Right cursor of "">"" is bad");
218 return Right.Node.Key < Left;
226 new Tree_Operations.Generic_Adjust (Copy_Tree);
228 procedure Adjust (Container : in out Map) is
230 Adjust (Container.Tree);
237 function Ceiling (Container : Map; Key : Key_Type) return Cursor is
238 Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
245 return Cursor'(Container'Unrestricted_Access, Node);
253 new Tree_Operations.Generic_Clear (Delete_Tree);
255 procedure Clear (Container : in out Map) is
257 Clear (Container.Tree);
264 function Color (Node : Node_Access) return Color_Type is
273 function Contains (Container : Map; Key : Key_Type) return Boolean is
275 return Find (Container, Key) /= No_Element;
282 function Copy_Node (Source : Node_Access) return Node_Access is
283 Target : constant Node_Access :=
284 new Node_Type'(Color => Source.Color,
286 Element => Source.Element,
298 procedure Delete (Container : in out Map; Position : in out Cursor) is
299 Tree : Tree_Type renames Container.Tree;
302 if Position.Node = null then
303 raise Constraint_Error with
304 "Position cursor of Delete equals No_Element";
307 if Position.Container /= Container'Unrestricted_Access then
308 raise Program_Error with
309 "Position cursor of Delete designates wrong map";
312 pragma Assert (Vet (Tree, Position.Node),
313 "Position cursor of Delete is bad");
315 Tree_Operations.Delete_Node_Sans_Free (Tree, Position.Node);
316 Free (Position.Node);
318 Position.Container := null;
321 procedure Delete (Container : in out Map; Key : Key_Type) is
322 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
326 raise Constraint_Error with "key not in map";
329 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
337 procedure Delete_First (Container : in out Map) is
338 X : Node_Access := Container.Tree.First;
342 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
351 procedure Delete_Last (Container : in out Map) is
352 X : Node_Access := Container.Tree.Last;
356 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
365 function Element (Position : Cursor) return Element_Type is
367 if Position.Node = null then
368 raise Constraint_Error with
369 "Position cursor of function Element equals No_Element";
372 pragma Assert (Vet (Position.Container.Tree, Position.Node),
373 "Position cursor of function Element is bad");
375 return Position.Node.Element;
378 function Element (Container : Map; Key : Key_Type) return Element_Type is
379 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
383 raise Constraint_Error with "key not in map";
389 ---------------------
390 -- Equivalent_Keys --
391 ---------------------
393 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
408 procedure Exclude (Container : in out Map; Key : Key_Type) is
409 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
413 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
422 function Find (Container : Map; Key : Key_Type) return Cursor is
423 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
430 return Cursor'(Container'Unrestricted_Access, Node);
437 function First (Container : Map) return Cursor is
438 T : Tree_Type renames Container.Tree;
441 if T.First = null then
445 return Cursor'(Container'Unrestricted_Access, T.First);
452 function First_Element (Container : Map) return Element_Type is
453 T : Tree_Type renames Container.Tree;
456 if T.First = null then
457 raise Constraint_Error with "map is empty";
460 return T.First.Element;
467 function First_Key (Container : Map) return Key_Type is
468 T : Tree_Type renames Container.Tree;
471 if T.First = null then
472 raise Constraint_Error with "map is empty";
482 function Floor (Container : Map; Key : Key_Type) return Cursor is
483 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
490 return Cursor'(Container'Unrestricted_Access, Node);
497 procedure Free (X : in out Node_Access) is
498 procedure Deallocate is
499 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
517 function Has_Element (Position : Cursor) return Boolean is
519 return Position /= No_Element;
527 (Container : in out Map;
529 New_Item : Element_Type)
535 Insert (Container, Key, New_Item, Position, Inserted);
538 if Container.Tree.Lock > 0 then
539 raise Program_Error with
540 "attempt to tamper with elements (map is locked)";
543 Position.Node.Key := Key;
544 Position.Node.Element := New_Item;
553 (Container : in out Map;
555 New_Item : Element_Type;
556 Position : out Cursor;
557 Inserted : out Boolean)
559 function New_Node return Node_Access;
560 pragma Inline (New_Node);
562 procedure Insert_Post is
563 new Key_Ops.Generic_Insert_Post (New_Node);
565 procedure Insert_Sans_Hint is
566 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
572 function New_Node return Node_Access is
574 return new Node_Type'(Key => Key,
576 Color => Red_Black_Trees.Red,
582 -- Start of processing for Insert
591 Position.Container := Container'Unrestricted_Access;
595 (Container : in out Map;
597 New_Item : Element_Type)
600 pragma Unreferenced (Position);
605 Insert (Container, Key, New_Item, Position, Inserted);
608 raise Constraint_Error with "key already in map";
613 (Container : in out Map;
615 Position : out Cursor;
616 Inserted : out Boolean)
618 function New_Node return Node_Access;
619 pragma Inline (New_Node);
621 procedure Insert_Post is
622 new Key_Ops.Generic_Insert_Post (New_Node);
624 procedure Insert_Sans_Hint is
625 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
631 function New_Node return Node_Access is
633 return new Node_Type'(Key => Key,
635 Color => Red_Black_Trees.Red,
641 -- Start of processing for Insert
650 Position.Container := Container'Unrestricted_Access;
657 function Is_Empty (Container : Map) return Boolean is
659 return Container.Tree.Length = 0;
662 ------------------------
663 -- Is_Equal_Node_Node --
664 ------------------------
666 function Is_Equal_Node_Node
667 (L, R : Node_Access) return Boolean is
669 if L.Key < R.Key then
672 elsif R.Key < L.Key then
676 return L.Element = R.Element;
678 end Is_Equal_Node_Node;
680 -------------------------
681 -- Is_Greater_Key_Node --
682 -------------------------
684 function Is_Greater_Key_Node
686 Right : Node_Access) return Boolean
689 -- k > node same as node < k
691 return Right.Key < Left;
692 end Is_Greater_Key_Node;
694 ----------------------
695 -- Is_Less_Key_Node --
696 ----------------------
698 function Is_Less_Key_Node
700 Right : Node_Access) return Boolean
703 return Left < Right.Key;
704 end Is_Less_Key_Node;
712 Process : not null access procedure (Position : Cursor))
714 procedure Process_Node (Node : Node_Access);
715 pragma Inline (Process_Node);
717 procedure Local_Iterate is
718 new Tree_Operations.Generic_Iteration (Process_Node);
724 procedure Process_Node (Node : Node_Access) is
726 Process (Cursor'(Container'Unrestricted_Access, Node));
729 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
731 -- Start of processing for Iterate
737 Local_Iterate (Container.Tree);
751 function Key (Position : Cursor) return Key_Type is
753 if Position.Node = null then
754 raise Constraint_Error with
755 "Position cursor of function Key equals No_Element";
758 pragma Assert (Vet (Position.Container.Tree, Position.Node),
759 "Position cursor of function Key is bad");
761 return Position.Node.Key;
768 function Last (Container : Map) return Cursor is
769 T : Tree_Type renames Container.Tree;
772 if T.Last = null then
776 return Cursor'(Container'Unrestricted_Access, T.Last);
783 function Last_Element (Container : Map) return Element_Type is
784 T : Tree_Type renames Container.Tree;
787 if T.Last = null then
788 raise Constraint_Error with "map is empty";
791 return T.Last.Element;
798 function Last_Key (Container : Map) return Key_Type is
799 T : Tree_Type renames Container.Tree;
802 if T.Last = null then
803 raise Constraint_Error with "map is empty";
813 function Left (Node : Node_Access) return Node_Access is
822 function Length (Container : Map) return Count_Type is
824 return Container.Tree.Length;
832 new Tree_Operations.Generic_Move (Clear);
834 procedure Move (Target : in out Map; Source : in out Map) is
836 Move (Target => Target.Tree, Source => Source.Tree);
843 procedure Next (Position : in out Cursor) is
845 Position := Next (Position);
848 function Next (Position : Cursor) return Cursor is
850 if Position = No_Element then
854 pragma Assert (Vet (Position.Container.Tree, Position.Node),
855 "Position cursor of Next is bad");
858 Node : constant Node_Access :=
859 Tree_Operations.Next (Position.Node);
866 return Cursor'(Position.Container, Node);
874 function Parent (Node : Node_Access) return Node_Access is
883 procedure Previous (Position : in out Cursor) is
885 Position := Previous (Position);
888 function Previous (Position : Cursor) return Cursor is
890 if Position = No_Element then
894 pragma Assert (Vet (Position.Container.Tree, Position.Node),
895 "Position cursor of Previous is bad");
898 Node : constant Node_Access :=
899 Tree_Operations.Previous (Position.Node);
906 return Cursor'(Position.Container, Node);
914 procedure Query_Element
916 Process : not null access procedure (Key : Key_Type;
917 Element : Element_Type))
920 if Position.Node = null then
921 raise Constraint_Error with
922 "Position cursor of Query_Element equals No_Element";
925 pragma Assert (Vet (Position.Container.Tree, Position.Node),
926 "Position cursor of Query_Element is bad");
929 T : Tree_Type renames Position.Container.Tree;
931 B : Natural renames T.Busy;
932 L : Natural renames T.Lock;
939 K : Key_Type renames Position.Node.Key;
940 E : Element_Type renames Position.Node.Element;
961 (Stream : not null access Root_Stream_Type'Class;
965 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
966 pragma Inline (Read_Node);
969 new Tree_Operations.Generic_Read (Clear, Read_Node);
976 (Stream : not null access Root_Stream_Type'Class) return Node_Access
978 Node : Node_Access := new Node_Type;
980 Key_Type'Read (Stream, Node.Key);
981 Element_Type'Read (Stream, Node.Element);
989 -- Start of processing for Read
992 Read (Stream, Container.Tree);
996 (Stream : not null access Root_Stream_Type'Class;
1000 raise Program_Error with "attempt to stream map cursor";
1008 (Container : in out Map;
1010 New_Item : Element_Type)
1012 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1016 raise Constraint_Error with "key not in map";
1019 if Container.Tree.Lock > 0 then
1020 raise Program_Error with
1021 "attempt to tamper with elements (map is locked)";
1025 Node.Element := New_Item;
1028 ---------------------
1029 -- Replace_Element --
1030 ---------------------
1032 procedure Replace_Element
1033 (Container : in out Map;
1035 New_Item : Element_Type)
1038 if Position.Node = null then
1039 raise Constraint_Error with
1040 "Position cursor of Replace_Element equals No_Element";
1043 if Position.Container /= Container'Unrestricted_Access then
1044 raise Program_Error with
1045 "Position cursor of Replace_Element designates wrong map";
1048 if Container.Tree.Lock > 0 then
1049 raise Program_Error with
1050 "attempt to tamper with elements (map is locked)";
1053 pragma Assert (Vet (Container.Tree, Position.Node),
1054 "Position cursor of Replace_Element is bad");
1056 Position.Node.Element := New_Item;
1057 end Replace_Element;
1059 ---------------------
1060 -- Reverse_Iterate --
1061 ---------------------
1063 procedure Reverse_Iterate
1065 Process : not null access procedure (Position : Cursor))
1067 procedure Process_Node (Node : Node_Access);
1068 pragma Inline (Process_Node);
1070 procedure Local_Reverse_Iterate is
1071 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1077 procedure Process_Node (Node : Node_Access) is
1079 Process (Cursor'(Container'Unrestricted_Access, Node));
1082 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
1084 -- Start of processing for Reverse_Iterate
1090 Local_Reverse_Iterate (Container.Tree);
1098 end Reverse_Iterate;
1104 function Right (Node : Node_Access) return Node_Access is
1114 (Node : Node_Access;
1118 Node.Color := Color;
1125 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1134 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1136 Node.Parent := Parent;
1143 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1145 Node.Right := Right;
1148 --------------------
1149 -- Update_Element --
1150 --------------------
1152 procedure Update_Element
1153 (Container : in out Map;
1155 Process : not null access procedure (Key : Key_Type;
1156 Element : in out Element_Type))
1159 if Position.Node = null then
1160 raise Constraint_Error with
1161 "Position cursor of Update_Element equals No_Element";
1164 if Position.Container /= Container'Unrestricted_Access then
1165 raise Program_Error with
1166 "Position cursor of Update_Element designates wrong map";
1169 pragma Assert (Vet (Container.Tree, Position.Node),
1170 "Position cursor of Update_Element is bad");
1173 T : Tree_Type renames Container.Tree;
1175 B : Natural renames T.Busy;
1176 L : Natural renames T.Lock;
1183 K : Key_Type renames Position.Node.Key;
1184 E : Element_Type renames Position.Node.Element;
1206 (Stream : not null access Root_Stream_Type'Class;
1209 procedure Write_Node
1210 (Stream : not null access Root_Stream_Type'Class;
1211 Node : Node_Access);
1212 pragma Inline (Write_Node);
1215 new Tree_Operations.Generic_Write (Write_Node);
1221 procedure Write_Node
1222 (Stream : not null access Root_Stream_Type'Class;
1226 Key_Type'Write (Stream, Node.Key);
1227 Element_Type'Write (Stream, Node.Element);
1230 -- Start of processing for Write
1233 Write (Stream, Container.Tree);
1237 (Stream : not null access Root_Stream_Type'Class;
1241 raise Program_Error with "attempt to stream map cursor";
1244 end Ada.Containers.Ordered_Maps;