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-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.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)
598 pragma Unreferenced (Position);
603 Insert (Container, Key, New_Item, Position, Inserted);
606 raise Constraint_Error with "key already in map";
615 (Container : in out Map;
617 Position : out Cursor;
618 Inserted : out Boolean)
620 function New_Node return Node_Access;
621 pragma Inline (New_Node);
623 procedure Insert_Post is
624 new Key_Ops.Generic_Insert_Post (New_Node);
626 procedure Insert_Sans_Hint is
627 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
633 function New_Node return Node_Access is
635 return new Node_Type'(Key => Key,
637 Color => Red_Black_Trees.Red,
643 -- Start of processing for Insert
652 Position.Container := Container'Unrestricted_Access;
659 function Is_Empty (Container : Map) return Boolean is
661 return Container.Tree.Length = 0;
664 ------------------------
665 -- Is_Equal_Node_Node --
666 ------------------------
668 function Is_Equal_Node_Node
669 (L, R : Node_Access) return Boolean is
671 if L.Key < R.Key then
674 elsif R.Key < L.Key then
678 return L.Element = R.Element;
680 end Is_Equal_Node_Node;
682 -------------------------
683 -- Is_Greater_Key_Node --
684 -------------------------
686 function Is_Greater_Key_Node
688 Right : Node_Access) return Boolean
691 -- k > node same as node < k
693 return Right.Key < Left;
694 end Is_Greater_Key_Node;
696 ----------------------
697 -- Is_Less_Key_Node --
698 ----------------------
700 function Is_Less_Key_Node
702 Right : Node_Access) return Boolean
705 return Left < Right.Key;
706 end Is_Less_Key_Node;
714 Process : not null access procedure (Position : Cursor))
716 procedure Process_Node (Node : Node_Access);
717 pragma Inline (Process_Node);
719 procedure Local_Iterate is
720 new Tree_Operations.Generic_Iteration (Process_Node);
726 procedure Process_Node (Node : Node_Access) is
728 Process (Cursor'(Container'Unrestricted_Access, Node));
731 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
733 -- Start of processing for Iterate
739 Local_Iterate (Container.Tree);
753 function Key (Position : Cursor) return Key_Type is
755 if Position.Node = null then
756 raise Constraint_Error with
757 "Position cursor of function Key equals No_Element";
760 pragma Assert (Vet (Position.Container.Tree, Position.Node),
761 "Position cursor of function Key is bad");
763 return Position.Node.Key;
770 function Last (Container : Map) return Cursor is
771 T : Tree_Type renames Container.Tree;
774 if T.Last = null then
778 return Cursor'(Container'Unrestricted_Access, T.Last);
785 function Last_Element (Container : Map) return Element_Type is
786 T : Tree_Type renames Container.Tree;
789 if T.Last = null then
790 raise Constraint_Error with "map is empty";
793 return T.Last.Element;
800 function Last_Key (Container : Map) return Key_Type is
801 T : Tree_Type renames Container.Tree;
804 if T.Last = null then
805 raise Constraint_Error with "map is empty";
815 function Left (Node : Node_Access) return Node_Access is
824 function Length (Container : Map) return Count_Type is
826 return Container.Tree.Length;
834 new Tree_Operations.Generic_Move (Clear);
836 procedure Move (Target : in out Map; Source : in out Map) is
838 Move (Target => Target.Tree, Source => Source.Tree);
845 procedure Next (Position : in out Cursor) is
847 Position := Next (Position);
850 function Next (Position : Cursor) return Cursor is
852 if Position = No_Element then
856 pragma Assert (Vet (Position.Container.Tree, Position.Node),
857 "Position cursor of Next is bad");
860 Node : constant Node_Access :=
861 Tree_Operations.Next (Position.Node);
868 return Cursor'(Position.Container, Node);
876 function Parent (Node : Node_Access) return Node_Access is
885 procedure Previous (Position : in out Cursor) is
887 Position := Previous (Position);
890 function Previous (Position : Cursor) return Cursor is
892 if Position = No_Element then
896 pragma Assert (Vet (Position.Container.Tree, Position.Node),
897 "Position cursor of Previous is bad");
900 Node : constant Node_Access :=
901 Tree_Operations.Previous (Position.Node);
908 return Cursor'(Position.Container, Node);
916 procedure Query_Element
918 Process : not null access procedure (Key : Key_Type;
919 Element : Element_Type))
922 if Position.Node = null then
923 raise Constraint_Error with
924 "Position cursor of Query_Element equals No_Element";
927 pragma Assert (Vet (Position.Container.Tree, Position.Node),
928 "Position cursor of Query_Element is bad");
931 T : Tree_Type renames Position.Container.Tree;
933 B : Natural renames T.Busy;
934 L : Natural renames T.Lock;
941 K : Key_Type renames Position.Node.Key;
942 E : Element_Type renames Position.Node.Element;
963 (Stream : not null access Root_Stream_Type'Class;
967 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
968 pragma Inline (Read_Node);
971 new Tree_Operations.Generic_Read (Clear, Read_Node);
978 (Stream : not null access Root_Stream_Type'Class) return Node_Access
980 Node : Node_Access := new Node_Type;
982 Key_Type'Read (Stream, Node.Key);
983 Element_Type'Read (Stream, Node.Element);
991 -- Start of processing for Read
994 Read (Stream, Container.Tree);
998 (Stream : not null access Root_Stream_Type'Class;
1002 raise Program_Error with "attempt to stream map cursor";
1010 (Container : in out Map;
1012 New_Item : Element_Type)
1014 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1018 raise Constraint_Error with "key not in map";
1021 if Container.Tree.Lock > 0 then
1022 raise Program_Error with
1023 "attempt to tamper with cursors (map is locked)";
1027 Node.Element := New_Item;
1030 ---------------------
1031 -- Replace_Element --
1032 ---------------------
1034 procedure Replace_Element
1035 (Container : in out Map;
1037 New_Item : Element_Type)
1040 if Position.Node = null then
1041 raise Constraint_Error with
1042 "Position cursor of Replace_Element equals No_Element";
1045 if Position.Container /= Container'Unrestricted_Access then
1046 raise Program_Error with
1047 "Position cursor of Replace_Element designates wrong map";
1050 if Container.Tree.Lock > 0 then
1051 raise Program_Error with
1052 "attempt to tamper with cursors (map is locked)";
1055 pragma Assert (Vet (Container.Tree, Position.Node),
1056 "Position cursor of Replace_Element is bad");
1058 Position.Node.Element := New_Item;
1059 end Replace_Element;
1061 ---------------------
1062 -- Reverse_Iterate --
1063 ---------------------
1065 procedure Reverse_Iterate
1067 Process : not null access procedure (Position : Cursor))
1069 procedure Process_Node (Node : Node_Access);
1070 pragma Inline (Process_Node);
1072 procedure Local_Reverse_Iterate is
1073 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1079 procedure Process_Node (Node : Node_Access) is
1081 Process (Cursor'(Container'Unrestricted_Access, Node));
1084 B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
1086 -- Start of processing for Reverse_Iterate
1092 Local_Reverse_Iterate (Container.Tree);
1100 end Reverse_Iterate;
1106 function Right (Node : Node_Access) return Node_Access is
1116 (Node : Node_Access;
1120 Node.Color := Color;
1127 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1136 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1138 Node.Parent := Parent;
1145 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1147 Node.Right := Right;
1150 --------------------
1151 -- Update_Element --
1152 --------------------
1154 procedure Update_Element
1155 (Container : in out Map;
1157 Process : not null access procedure (Key : Key_Type;
1158 Element : in out Element_Type))
1161 if Position.Node = null then
1162 raise Constraint_Error with
1163 "Position cursor of Update_Element equals No_Element";
1166 if Position.Container /= Container'Unrestricted_Access then
1167 raise Program_Error with
1168 "Position cursor of Update_Element designates wrong map";
1171 pragma Assert (Vet (Container.Tree, Position.Node),
1172 "Position cursor of Update_Element is bad");
1175 T : Tree_Type renames Container.Tree;
1177 B : Natural renames T.Busy;
1178 L : Natural renames T.Lock;
1185 K : Key_Type renames Position.Node.Key;
1186 E : Element_Type renames Position.Node.Element;
1208 (Stream : not null access Root_Stream_Type'Class;
1211 procedure Write_Node
1212 (Stream : not null access Root_Stream_Type'Class;
1213 Node : Node_Access);
1214 pragma Inline (Write_Node);
1217 new Tree_Operations.Generic_Write (Write_Node);
1223 procedure Write_Node
1224 (Stream : not null access Root_Stream_Type'Class;
1228 Key_Type'Write (Stream, Node.Key);
1229 Element_Type'Write (Stream, Node.Element);
1232 -- Start of processing for Write
1235 Write (Stream, Container.Tree);
1239 (Stream : not null access Root_Stream_Type'Class;
1243 raise Program_Error with "attempt to stream map cursor";
1246 end Ada.Containers.Ordered_Maps;