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-2006, 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.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 (L, R : Node_Access) return Boolean;
83 pragma Inline (Is_Equal_Node_Node);
85 function Is_Greater_Key_Node
87 Right : Node_Access) return Boolean;
88 pragma Inline (Is_Greater_Key_Node);
90 function Is_Less_Key_Node
92 Right : Node_Access) return Boolean;
93 pragma Inline (Is_Less_Key_Node);
95 --------------------------
96 -- Local Instantiations --
97 --------------------------
99 package Tree_Operations is
100 new Red_Black_Trees.Generic_Operations (Tree_Types);
102 procedure Delete_Tree is
103 new Tree_Operations.Generic_Delete_Tree (Free);
105 function Copy_Tree is
106 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
111 new Red_Black_Trees.Generic_Keys
112 (Tree_Operations => Tree_Operations,
113 Key_Type => Key_Type,
114 Is_Less_Key_Node => Is_Less_Key_Node,
115 Is_Greater_Key_Node => Is_Greater_Key_Node);
118 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
124 function "<" (Left, Right : Cursor) return Boolean is
126 if Left.Node = null then
127 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
130 if Right.Node = null then
131 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
134 pragma Assert (Vet (Left.Container.Tree, Left.Node),
135 "Left cursor of ""<"" is bad");
137 pragma Assert (Vet (Right.Container.Tree, Right.Node),
138 "Right cursor of ""<"" is bad");
140 return Left.Node.Key < Right.Node.Key;
143 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
145 if Left.Node = null then
146 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
149 pragma Assert (Vet (Left.Container.Tree, Left.Node),
150 "Left cursor of ""<"" is bad");
152 return Left.Node.Key < Right;
155 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
157 if Right.Node = null then
158 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
161 pragma Assert (Vet (Right.Container.Tree, Right.Node),
162 "Right cursor of ""<"" is bad");
164 return Left < Right.Node.Key;
171 function "=" (Left, Right : Map) return Boolean is
173 return Is_Equal (Left.Tree, Right.Tree);
180 function ">" (Left, Right : Cursor) return Boolean is
182 if Left.Node = null then
183 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
186 if Right.Node = null then
187 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
190 pragma Assert (Vet (Left.Container.Tree, Left.Node),
191 "Left cursor of "">"" is bad");
193 pragma Assert (Vet (Right.Container.Tree, Right.Node),
194 "Right cursor of "">"" is bad");
196 return Right.Node.Key < Left.Node.Key;
199 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
201 if Left.Node = null then
202 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
205 pragma Assert (Vet (Left.Container.Tree, Left.Node),
206 "Left cursor of "">"" is bad");
208 return Right < Left.Node.Key;
211 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
213 if Right.Node = null then
214 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
217 pragma Assert (Vet (Right.Container.Tree, Right.Node),
218 "Right cursor of "">"" is bad");
220 return Right.Node.Key < Left;
228 new Tree_Operations.Generic_Adjust (Copy_Tree);
230 procedure Adjust (Container : in out Map) is
232 Adjust (Container.Tree);
239 function Ceiling (Container : Map; Key : Key_Type) return Cursor is
240 Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
247 return Cursor'(Container'Unrestricted_Access, Node);
255 new Tree_Operations.Generic_Clear (Delete_Tree);
257 procedure Clear (Container : in out Map) is
259 Clear (Container.Tree);
266 function Color (Node : Node_Access) return Color_Type is
275 function Contains (Container : Map; Key : Key_Type) return Boolean is
277 return Find (Container, Key) /= No_Element;
284 function Copy_Node (Source : Node_Access) return Node_Access is
285 Target : constant Node_Access :=
286 new Node_Type'(Color => Source.Color,
288 Element => Source.Element,
300 procedure Delete (Container : in out Map; Position : in out Cursor) is
301 Tree : Tree_Type renames Container.Tree;
304 if Position.Node = null then
305 raise Constraint_Error with
306 "Position cursor of Delete equals No_Element";
309 if Position.Container /= Container'Unrestricted_Access then
310 raise Program_Error with
311 "Position cursor of Delete designates wrong map";
314 pragma Assert (Vet (Tree, Position.Node),
315 "Position cursor of Delete is bad");
317 Tree_Operations.Delete_Node_Sans_Free (Tree, Position.Node);
318 Free (Position.Node);
320 Position.Container := null;
323 procedure Delete (Container : in out Map; Key : Key_Type) is
324 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
328 raise Constraint_Error with "key not in map";
331 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
339 procedure Delete_First (Container : in out Map) is
340 X : Node_Access := Container.Tree.First;
344 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
353 procedure Delete_Last (Container : in out Map) is
354 X : Node_Access := Container.Tree.Last;
358 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
367 function Element (Position : Cursor) return Element_Type is
369 if Position.Node = null then
370 raise Constraint_Error with
371 "Position cursor of function Element equals No_Element";
374 pragma Assert (Vet (Position.Container.Tree, Position.Node),
375 "Position cursor of function Element is bad");
377 return Position.Node.Element;
380 function Element (Container : Map; Key : Key_Type) return Element_Type is
381 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
385 raise Constraint_Error with "key not in map";
391 ---------------------
392 -- Equivalent_Keys --
393 ---------------------
395 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
410 procedure Exclude (Container : in out Map; Key : Key_Type) is
411 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
415 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
424 function Find (Container : Map; Key : Key_Type) return Cursor is
425 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
432 return Cursor'(Container'Unrestricted_Access, Node);
439 function First (Container : Map) return Cursor is
440 T : Tree_Type renames Container.Tree;
443 if T.First = null then
447 return Cursor'(Container'Unrestricted_Access, T.First);
454 function First_Element (Container : Map) return Element_Type is
455 T : Tree_Type renames Container.Tree;
458 if T.First = null then
459 raise Constraint_Error with "map is empty";
462 return T.First.Element;
469 function First_Key (Container : Map) return Key_Type is
470 T : Tree_Type renames Container.Tree;
473 if T.First = null then
474 raise Constraint_Error with "map is empty";
484 function Floor (Container : Map; Key : Key_Type) return Cursor is
485 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
492 return Cursor'(Container'Unrestricted_Access, Node);
499 procedure Free (X : in out Node_Access) is
500 procedure Deallocate is
501 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
519 function Has_Element (Position : Cursor) return Boolean is
521 return Position /= No_Element;
529 (Container : in out Map;
531 New_Item : Element_Type)
537 Insert (Container, Key, New_Item, Position, Inserted);
540 if Container.Tree.Lock > 0 then
541 raise Program_Error with
542 "attempt to tamper with cursors (map is locked)";
545 Position.Node.Key := Key;
546 Position.Node.Element := New_Item;
551 (Container : in out Map;
553 New_Item : Element_Type;
554 Position : out Cursor;
555 Inserted : out Boolean)
557 function New_Node return Node_Access;
558 pragma Inline (New_Node);
560 procedure Insert_Post is
561 new Key_Ops.Generic_Insert_Post (New_Node);
563 procedure Insert_Sans_Hint is
564 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
570 function New_Node return Node_Access is
572 return new Node_Type'(Key => Key,
574 Color => Red_Black_Trees.Red,
580 -- Start of processing for Insert
589 Position.Container := Container'Unrestricted_Access;
593 (Container : in out Map;
595 New_Item : Element_Type)
601 Insert (Container, Key, New_Item, Position, Inserted);
604 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 cursors (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 cursors (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;
1205 (Stream : not null access Root_Stream_Type'Class;
1208 procedure Write_Node
1209 (Stream : not null access Root_Stream_Type'Class;
1210 Node : Node_Access);
1211 pragma Inline (Write_Node);
1214 new Tree_Operations.Generic_Write (Write_Node);
1220 procedure Write_Node
1221 (Stream : not null access Root_Stream_Type'Class;
1225 Key_Type'Write (Stream, Node.Key);
1226 Element_Type'Write (Stream, Node.Element);
1229 -- Start of processing for Write
1232 Write (Stream, Container.Tree);
1236 (Stream : not null access Root_Stream_Type'Class;
1240 raise Program_Error with "attempt to stream map cursor";
1243 end Ada.Containers.Ordered_Maps;