1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.ORDERED_MAPS --
9 -- Copyright (C) 2004 Free Software Foundation, Inc. --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the contents of the part following the private keyword. --
15 -- GNAT is free software; you can redistribute it and/or modify it under --
16 -- terms of the GNU General Public License as published by the Free Soft- --
17 -- ware Foundation; either version 2, or (at your option) any later ver- --
18 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
21 -- for more details. You should have received a copy of the GNU General --
22 -- Public License distributed with GNAT; see file COPYING. If not, write --
23 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
24 -- MA 02111-1307, USA. --
26 -- As a special exception, if other files instantiate generics from this --
27 -- unit, or you link this unit with other files to produce an executable, --
28 -- this unit does not by itself cause the resulting executable to be --
29 -- covered by the GNU General Public License. This exception does not --
30 -- however invalidate any other reasons why the executable file might be --
31 -- covered by the GNU Public License. --
33 -- This unit was originally developed by Matthew J Heaney. --
34 ------------------------------------------------------------------------------
36 with Ada.Unchecked_Deallocation;
38 with Ada.Containers.Red_Black_Trees.Generic_Operations;
39 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
41 with Ada.Containers.Red_Black_Trees.Generic_Keys;
42 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
44 with System; use type System.Address;
46 package body Ada.Containers.Ordered_Maps is
50 type Node_Type is limited record
54 Color : Red_Black_Trees.Color_Type := Red;
56 Element : Element_Type;
59 -----------------------------
60 -- Node Access Subprograms --
61 -----------------------------
63 -- These subprograms provide a functional interface to access fields
64 -- of a node, and a procedural interface for modifying these values.
66 function Color (Node : Node_Access) return Color_Type;
67 pragma Inline (Color);
69 function Left (Node : Node_Access) return Node_Access;
72 function Parent (Node : Node_Access) return Node_Access;
73 pragma Inline (Parent);
75 function Right (Node : Node_Access) return Node_Access;
76 pragma Inline (Right);
78 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
79 pragma Inline (Set_Parent);
81 procedure Set_Left (Node : Node_Access; Left : Node_Access);
82 pragma Inline (Set_Left);
84 procedure Set_Right (Node : Node_Access; Right : Node_Access);
85 pragma Inline (Set_Right);
87 procedure Set_Color (Node : Node_Access; Color : Color_Type);
88 pragma Inline (Set_Color);
90 -----------------------
91 -- Local Subprograms --
92 -----------------------
94 function Copy_Node (Source : Node_Access) return Node_Access;
95 pragma Inline (Copy_Node);
97 function Copy_Tree (Source_Root : Node_Access) return Node_Access;
99 procedure Delete_Tree (X : in out Node_Access);
101 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
102 pragma Inline (Is_Equal_Node_Node);
104 function Is_Greater_Key_Node
106 Right : Node_Access) return Boolean;
107 pragma Inline (Is_Greater_Key_Node);
109 function Is_Less_Key_Node
111 Right : Node_Access) return Boolean;
112 pragma Inline (Is_Less_Key_Node);
114 --------------------------
115 -- Local Instantiations --
116 --------------------------
118 procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
120 package Tree_Operations is
121 new Red_Black_Trees.Generic_Operations
122 (Tree_Types => Tree_Types,
123 Null_Node => Node_Access'(null));
128 new Red_Black_Trees.Generic_Keys
129 (Tree_Operations => Tree_Operations,
130 Key_Type => Key_Type,
131 Is_Less_Key_Node => Is_Less_Key_Node,
132 Is_Greater_Key_Node => Is_Greater_Key_Node);
135 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
141 function "<" (Left, Right : Cursor) return Boolean is
143 return Left.Node.Key < Right.Node.Key;
146 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
148 return Left.Node.Key < Right;
151 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
153 return Left < Right.Node.Key;
160 function "=" (Left, Right : Map) return Boolean is
162 if Left'Address = Right'Address then
166 return Is_Equal (Left.Tree, Right.Tree);
173 function ">" (Left, Right : Cursor) return Boolean is
175 return Right.Node.Key < Left.Node.Key;
178 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
180 return Right < Left.Node.Key;
183 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
185 return Right.Node.Key < Left;
192 procedure Adjust (Container : in out Map) is
193 Tree : Tree_Type renames Container.Tree;
195 N : constant Count_Type := Tree.Length;
196 X : constant Node_Access := Tree.Root;
200 pragma Assert (X = null);
204 Tree := (Length => 0, others => null);
206 Tree.Root := Copy_Tree (X);
207 Tree.First := Min (Tree.Root);
208 Tree.Last := Max (Tree.Root);
216 function Ceiling (Container : Map; Key : Key_Type) return Cursor is
217 Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
224 return Cursor'(Container'Unchecked_Access, Node);
231 procedure Clear (Container : in out Map) is
232 Tree : Tree_Type renames Container.Tree;
233 Root : Node_Access := Tree.Root;
235 Tree := (Length => 0, others => null);
243 function Color (Node : Node_Access) return Color_Type is
252 function Contains (Container : Map; Key : Key_Type) return Boolean is
254 return Find (Container, Key) /= No_Element;
261 function Copy_Node (Source : Node_Access) return Node_Access is
262 Target : constant Node_Access :=
263 new Node_Type'(Parent => null,
266 Color => Source.Color,
268 Element => Source.Element);
277 function Copy_Tree (Source_Root : Node_Access) return Node_Access is
278 Target_Root : Node_Access := Copy_Node (Source_Root);
282 if Source_Root.Right /= null then
283 Target_Root.Right := Copy_Tree (Source_Root.Right);
284 Target_Root.Right.Parent := Target_Root;
288 X := Source_Root.Left;
292 Y : Node_Access := Copy_Node (X);
298 if X.Right /= null then
299 Y.Right := Copy_Tree (X.Right);
312 Delete_Tree (Target_Root);
320 procedure Delete (Container : in out Map; Position : in out Cursor) is
322 if Position = No_Element then
326 if Position.Container /= Map_Access'(Container'Unchecked_Access) then
330 Delete_Node_Sans_Free (Container.Tree, Position.Node);
331 Free (Position.Node);
333 Position.Container := null;
336 procedure Delete (Container : in out Map; Key : Key_Type) is
337 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
341 raise Constraint_Error;
344 Delete_Node_Sans_Free (Container.Tree, X);
352 procedure Delete_First (Container : in out Map) is
353 Position : Cursor := First (Container);
355 Delete (Container, Position);
362 procedure Delete_Last (Container : in out Map) is
363 Position : Cursor := Last (Container);
365 Delete (Container, Position);
373 procedure Delete_Tree (X : in out Node_Access) is
389 function Element (Position : Cursor) return Element_Type is
391 return Position.Node.Element;
394 function Element (Container : Map; Key : Key_Type) return Element_Type is
395 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
404 procedure Exclude (Container : in out Map; Key : Key_Type) is
405 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
409 Delete_Node_Sans_Free (Container.Tree, X);
418 function Find (Container : Map; Key : Key_Type) return Cursor is
419 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
426 return Cursor'(Container'Unchecked_Access, Node);
433 function First (Container : Map) return Cursor is
435 if Container.Tree.First = null then
439 return Cursor'(Container'Unchecked_Access, Container.Tree.First);
446 function First_Element (Container : Map) return Element_Type is
448 return Container.Tree.First.Element;
455 function First_Key (Container : Map) return Key_Type is
457 return Container.Tree.First.Key;
464 function Floor (Container : Map; Key : Key_Type) return Cursor is
465 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
472 return Cursor'(Container'Unchecked_Access, Node);
479 function Has_Element (Position : Cursor) return Boolean is
481 return Position /= No_Element;
489 (Container : in out Map;
491 New_Item : Element_Type)
497 Insert (Container, Key, New_Item, Position, Inserted);
500 Position.Node.Key := Key;
501 Position.Node.Element := New_Item;
506 (Container : in out Map;
508 New_Item : Element_Type;
509 Position : out Cursor;
510 Inserted : out Boolean)
512 function New_Node return Node_Access;
513 pragma Inline (New_Node);
515 procedure Insert_Post is
516 new Key_Ops.Generic_Insert_Post (New_Node);
518 procedure Insert_Sans_Hint is
519 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
525 function New_Node return Node_Access is
526 Node : constant Node_Access :=
527 new Node_Type'(Parent => null,
532 Element => New_Item);
537 -- Start of processing for Insert
546 Position.Container := Container'Unchecked_Access;
550 (Container : in out Map;
552 New_Item : Element_Type)
558 Insert (Container, Key, New_Item, Position, Inserted);
561 raise Constraint_Error;
570 (Container : in out Map;
572 Position : out Cursor;
573 Inserted : out Boolean)
575 function New_Node return Node_Access;
576 pragma Inline (New_Node);
578 procedure Insert_Post is
579 new Key_Ops.Generic_Insert_Post (New_Node);
581 procedure Insert_Sans_Hint is
582 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
588 function New_Node return Node_Access is
589 Node : Node_Access := new Node_Type;
603 -- Start of processing for Insert
612 Position.Container := Container'Unchecked_Access;
619 function Is_Empty (Container : Map) return Boolean is
621 return Container.Tree.Length = 0;
624 ------------------------
625 -- Is_Equal_Node_Node --
626 ------------------------
628 function Is_Equal_Node_Node
629 (L, R : Node_Access) return Boolean is
631 return L.Element = R.Element;
632 end Is_Equal_Node_Node;
634 -------------------------
635 -- Is_Greater_Key_Node --
636 -------------------------
638 function Is_Greater_Key_Node
640 Right : Node_Access) return Boolean
643 -- k > node same as node < k
645 return Right.Key < Left;
646 end Is_Greater_Key_Node;
648 ----------------------
649 -- Is_Less_Key_Node --
650 ----------------------
652 function Is_Less_Key_Node
654 Right : Node_Access) return Boolean
657 return Left < Right.Key;
658 end Is_Less_Key_Node;
666 Process : not null access procedure (Position : Cursor))
668 procedure Process_Node (Node : Node_Access);
669 pragma Inline (Process_Node);
671 procedure Local_Iterate is
672 new Tree_Operations.Generic_Iteration (Process_Node);
678 procedure Process_Node (Node : Node_Access) is
680 Process (Cursor'(Container'Unchecked_Access, Node));
683 -- Start of processing for Iterate
686 Local_Iterate (Container.Tree);
693 function Key (Position : Cursor) return Key_Type is
695 return Position.Node.Key;
702 function Last (Container : Map) return Cursor is
704 if Container.Tree.Last = null then
708 return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
715 function Last_Element (Container : Map) return Element_Type is
717 return Container.Tree.Last.Element;
724 function Last_Key (Container : Map) return Key_Type is
726 return Container.Tree.Last.Key;
733 function Left (Node : Node_Access) return Node_Access is
742 function Length (Container : Map) return Count_Type is
744 return Container.Tree.Length;
751 procedure Move (Target : in out Map; Source : in out Map) is
753 if Target'Address = Source'Address then
757 Move (Target => Target.Tree, Source => Source.Tree);
764 procedure Next (Position : in out Cursor) is
766 Position := Next (Position);
769 function Next (Position : Cursor) return Cursor is
771 if Position = No_Element then
776 Node : constant Node_Access :=
777 Tree_Operations.Next (Position.Node);
784 return Cursor'(Position.Container, Node);
792 function Parent (Node : Node_Access) return Node_Access is
801 procedure Previous (Position : in out Cursor) is
803 Position := Previous (Position);
806 function Previous (Position : Cursor) return Cursor is
808 if Position = No_Element then
813 Node : constant Node_Access :=
814 Tree_Operations.Previous (Position.Node);
821 return Cursor'(Position.Container, Node);
829 procedure Query_Element
831 Process : not null access procedure (Element : Element_Type))
834 Process (Position.Node.Key, Position.Node.Element);
842 (Stream : access Root_Stream_Type'Class;
847 function New_Node return Node_Access;
848 pragma Inline (New_Node);
850 procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
856 function New_Node return Node_Access is
857 Node : Node_Access := new Node_Type;
861 Key_Type'Read (Stream, Node.Key);
862 Element_Type'Read (Stream, Node.Element);
872 -- Start of processing for Read
876 Count_Type'Base'Read (Stream, N);
877 pragma Assert (N >= 0);
879 Local_Read (Container.Tree, N);
887 (Container : in out Map;
889 New_Item : Element_Type)
891 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
895 raise Constraint_Error;
899 Node.Element := New_Item;
902 ---------------------
903 -- Replace_Element --
904 ---------------------
906 procedure Replace_Element (Position : Cursor; By : Element_Type) is
908 Position.Node.Element := By;
911 ---------------------
912 -- Reverse_Iterate --
913 ---------------------
915 procedure Reverse_Iterate
917 Process : not null access procedure (Position : Cursor))
919 procedure Process_Node (Node : Node_Access);
920 pragma Inline (Process_Node);
922 procedure Local_Reverse_Iterate is
923 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
929 procedure Process_Node (Node : Node_Access) is
931 Process (Cursor'(Container'Unchecked_Access, Node));
934 -- Start of processing for Reverse_Iterate
937 Local_Reverse_Iterate (Container.Tree);
944 function Right (Node : Node_Access) return Node_Access is
965 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
974 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
976 Node.Parent := Parent;
984 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
993 procedure Update_Element
995 Process : not null access procedure (Element : in out Element_Type))
998 Process (Position.Node.Key, Position.Node.Element);
1006 (Stream : access Root_Stream_Type'Class;
1009 procedure Process (Node : Node_Access);
1010 pragma Inline (Process);
1012 procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
1018 procedure Process (Node : Node_Access) is
1020 Key_Type'Write (Stream, Node.Key);
1021 Element_Type'Write (Stream, Node.Element);
1024 -- Start of processing for Write
1027 Count_Type'Base'Write (Stream, Container.Tree.Length);
1028 Iterate (Container.Tree);
1031 end Ada.Containers.Ordered_Maps;