1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_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.Indefinite_Ordered_Maps is
50 type Key_Access is access Key_Type;
51 type Element_Access is access Element_Type;
53 type Node_Type is limited record
57 Color : Red_Black_Trees.Color_Type := Red;
59 Element : Element_Access;
62 -----------------------------
63 -- Node Access Subprograms --
64 -----------------------------
66 -- These subprograms provide a functional interface to access fields
67 -- of a node, and a procedural interface for modifying these values.
69 function Color (Node : Node_Access) return Color_Type;
70 pragma Inline (Color);
72 function Left (Node : Node_Access) return Node_Access;
75 function Parent (Node : Node_Access) return Node_Access;
76 pragma Inline (Parent);
78 function Right (Node : Node_Access) return Node_Access;
79 pragma Inline (Right);
81 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
82 pragma Inline (Set_Parent);
84 procedure Set_Left (Node : Node_Access; Left : Node_Access);
85 pragma Inline (Set_Left);
87 procedure Set_Right (Node : Node_Access; Right : Node_Access);
88 pragma Inline (Set_Right);
90 procedure Set_Color (Node : Node_Access; Color : Color_Type);
91 pragma Inline (Set_Color);
93 -----------------------
94 -- Local Subprograms --
95 -----------------------
97 function Copy_Node (Source : Node_Access) return Node_Access;
98 pragma Inline (Copy_Node);
100 function Copy_Tree (Source_Root : Node_Access) return Node_Access;
102 procedure Delete_Tree (X : in out Node_Access);
104 procedure Free (X : in out Node_Access);
106 function Is_Equal_Node_Node
107 (L, R : Node_Access) return Boolean;
108 pragma Inline (Is_Equal_Node_Node);
110 function Is_Greater_Key_Node
112 Right : Node_Access) return Boolean;
113 pragma Inline (Is_Greater_Key_Node);
115 function Is_Less_Key_Node
117 Right : Node_Access) return Boolean;
118 pragma Inline (Is_Less_Key_Node);
120 --------------------------
121 -- Local Instantiations --
122 --------------------------
124 package Tree_Operations is
125 new Red_Black_Trees.Generic_Operations
126 (Tree_Types => Tree_Types,
127 Null_Node => Node_Access'(null));
132 new Red_Black_Trees.Generic_Keys
133 (Tree_Operations => Tree_Operations,
134 Key_Type => Key_Type,
135 Is_Less_Key_Node => Is_Less_Key_Node,
136 Is_Greater_Key_Node => Is_Greater_Key_Node);
138 procedure Free_Key is
139 new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
141 procedure Free_Element is
142 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
145 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
151 function "<" (Left, Right : Cursor) return Boolean is
153 return Left.Node.Key.all < Right.Node.Key.all;
156 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
158 return Left.Node.Key.all < Right;
161 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
163 return Left < Right.Node.Key.all;
170 function "=" (Left, Right : Map) return Boolean is
172 if Left'Address = Right'Address then
176 return Is_Equal (Left.Tree, Right.Tree);
183 function ">" (Left, Right : Cursor) return Boolean is
185 return Right.Node.Key.all < Left.Node.Key.all;
188 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
190 return Right < Left.Node.Key.all;
193 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
195 return Right.Node.Key.all < Left;
202 procedure Adjust (Container : in out Map) is
203 Tree : Tree_Type renames Container.Tree;
205 N : constant Count_Type := Tree.Length;
206 X : constant Node_Access := Tree.Root;
210 pragma Assert (X = null);
214 Tree := (Length => 0, others => null);
216 Tree.Root := Copy_Tree (X);
217 Tree.First := Min (Tree.Root);
218 Tree.Last := Max (Tree.Root);
226 function Ceiling (Container : Map; Key : Key_Type) return Cursor is
227 Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
232 return Cursor'(Container'Unchecked_Access, Node);
240 procedure Clear (Container : in out Map) is
241 Tree : Tree_Type renames Container.Tree;
242 Root : Node_Access := Tree.Root;
244 Tree := (Length => 0, others => null);
252 function Color (Node : Node_Access) return Color_Type is
261 function Contains (Container : Map; Key : Key_Type) return Boolean is
263 return Find (Container, Key) /= No_Element;
270 function Copy_Node (Source : Node_Access) return Node_Access is
271 Target : constant Node_Access :=
272 new Node_Type'(Parent => null,
275 Color => Source.Color,
277 Element => Source.Element);
286 function Copy_Tree (Source_Root : Node_Access) return Node_Access is
287 Target_Root : Node_Access := Copy_Node (Source_Root);
292 if Source_Root.Right /= null then
293 Target_Root.Right := Copy_Tree (Source_Root.Right);
294 Target_Root.Right.Parent := Target_Root;
298 X := Source_Root.Left;
301 Y : Node_Access := Copy_Node (X);
307 if X.Right /= null then
308 Y.Right := Copy_Tree (X.Right);
321 Delete_Tree (Target_Root);
330 (Container : in out Map;
331 Position : in out Cursor)
334 if Position = No_Element then
338 if Position.Container /= Map_Access'(Container'Unchecked_Access) then
342 Delete_Node_Sans_Free (Container.Tree, Position.Node);
343 Free (Position.Node);
345 Position.Container := null;
348 procedure Delete (Container : in out Map; Key : Key_Type) is
349 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
352 raise Constraint_Error;
354 Delete_Node_Sans_Free (Container.Tree, X);
363 procedure Delete_First (Container : in out Map) is
364 Position : Cursor := First (Container);
366 Delete (Container, Position);
373 procedure Delete_Last (Container : in out Map) is
374 Position : Cursor := Last (Container);
376 Delete (Container, Position);
383 procedure Delete_Tree (X : in out Node_Access) is
399 function Element (Position : Cursor) return Element_Type is
401 return Position.Node.Element.all;
404 function Element (Container : Map; Key : Key_Type) return Element_Type is
405 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
407 return Node.Element.all;
414 procedure Exclude (Container : in out Map; Key : Key_Type) is
415 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
419 Delete_Node_Sans_Free (Container.Tree, X);
428 function Find (Container : Map; Key : Key_Type) return Cursor is
429 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
434 return Cursor'(Container'Unchecked_Access, Node);
442 function First (Container : Map) return Cursor is
444 if Container.Tree.First = null then
447 return Cursor'(Container'Unchecked_Access, Container.Tree.First);
455 function First_Element (Container : Map) return Element_Type is
457 return Container.Tree.First.Element.all;
464 function First_Key (Container : Map) return Key_Type is
466 return Container.Tree.First.Key.all;
473 function Floor (Container : Map; Key : Key_Type) return Cursor is
474 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
479 return Cursor'(Container'Unchecked_Access, Node);
487 procedure Free (X : in out Node_Access) is
488 procedure Deallocate is
489 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
493 Free_Element (X.Element);
502 function Has_Element (Position : Cursor) return Boolean is
504 return Position /= No_Element;
512 (Container : in out Map;
514 New_Item : Element_Type)
523 Insert (Container, Key, New_Item, Position, Inserted);
526 K := Position.Node.Key;
527 E := Position.Node.Element;
529 Position.Node.Key := new Key_Type'(Key);
530 Position.Node.Element := new Element_Type'(New_Item);
542 (Container : in out Map;
544 New_Item : Element_Type;
545 Position : out Cursor;
546 Inserted : out Boolean)
548 function New_Node return Node_Access;
549 pragma Inline (New_Node);
551 procedure Insert_Post is
552 new Key_Ops.Generic_Insert_Post (New_Node);
554 procedure Insert_Sans_Hint is
555 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
561 function New_Node return Node_Access is
562 Node : Node_Access := new Node_Type;
565 Node.Key := new Key_Type'(Key);
566 Node.Element := new Element_Type'(New_Item);
572 -- On exception, deallocate key and elem
578 -- Start of processing for Insert
587 Position.Container := Container'Unchecked_Access;
591 (Container : in out Map;
593 New_Item : Element_Type)
600 Insert (Container, Key, New_Item, Position, Inserted);
603 raise Constraint_Error;
611 function Is_Empty (Container : Map) return Boolean is
613 return Container.Tree.Length = 0;
616 ------------------------
617 -- Is_Equal_Node_Node --
618 ------------------------
620 function Is_Equal_Node_Node
621 (L, R : Node_Access) return Boolean is
623 return L.Element.all = R.Element.all;
624 end Is_Equal_Node_Node;
626 -------------------------
627 -- Is_Greater_Key_Node --
628 -------------------------
630 function Is_Greater_Key_Node
632 Right : Node_Access) return Boolean
635 -- k > node same as node < k
637 return Right.Key.all < Left;
638 end Is_Greater_Key_Node;
640 ----------------------
641 -- Is_Less_Key_Node --
642 ----------------------
644 function Is_Less_Key_Node
646 Right : Node_Access) return Boolean is
648 return Left < Right.Key.all;
649 end Is_Less_Key_Node;
657 Process : not null access procedure (Position : Cursor))
659 procedure Process_Node (Node : Node_Access);
660 pragma Inline (Process_Node);
662 procedure Local_Iterate is
663 new Tree_Operations.Generic_Iteration (Process_Node);
669 procedure Process_Node (Node : Node_Access) is
671 Process (Cursor'(Container'Unchecked_Access, Node));
674 -- Start of processing for Iterate
677 Local_Iterate (Container.Tree);
684 function Key (Position : Cursor) return Key_Type is
686 return Position.Node.Key.all;
693 function Last (Container : Map) return Cursor is
695 if Container.Tree.Last = null then
698 return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
706 function Last_Element (Container : Map) return Element_Type is
708 return Container.Tree.Last.Element.all;
715 function Last_Key (Container : Map) return Key_Type is
717 return Container.Tree.Last.Key.all;
724 function Left (Node : Node_Access) return Node_Access is
733 function Length (Container : Map) return Count_Type is
735 return Container.Tree.Length;
742 procedure Move (Target : in out Map; Source : in out Map) is
744 if Target'Address = Source'Address then
748 Move (Target => Target.Tree, Source => Source.Tree);
755 function Next (Position : Cursor) return Cursor is
757 if Position = No_Element then
762 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
767 return Cursor'(Position.Container, Node);
772 procedure Next (Position : in out Cursor) is
774 Position := Next (Position);
781 function Parent (Node : Node_Access) return Node_Access is
790 function Previous (Position : Cursor) return Cursor is
792 if Position = No_Element then
797 Node : constant Node_Access :=
798 Tree_Operations.Previous (Position.Node);
804 return Cursor'(Position.Container, Node);
808 procedure Previous (Position : in out Cursor) is
810 Position := Previous (Position);
817 procedure Query_Element
819 Process : not null access procedure (Element : Element_Type))
822 Process (Position.Node.Key.all, Position.Node.Element.all);
830 (Stream : access Root_Stream_Type'Class;
835 function New_Node return Node_Access;
836 pragma Inline (New_Node);
838 procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
844 function New_Node return Node_Access is
845 Node : Node_Access := new Node_Type;
848 Node.Key := new Key_Type'(Key_Type'Input (Stream));
849 Node.Element := new Element_Type'(Element_Type'Input (Stream));
855 -- Deallocate key and elem too on exception
861 -- Start of processing for Read
866 Count_Type'Base'Read (Stream, N);
867 pragma Assert (N >= 0);
869 Local_Read (Container.Tree, N);
877 (Container : in out Map;
879 New_Item : Element_Type)
881 Node : constant Node_Access :=
882 Key_Ops.Find (Container.Tree, Key);
889 raise Constraint_Error;
895 Node.Key := new Key_Type'(Key);
896 Node.Element := new Element_Type'(New_Item);
902 ---------------------
903 -- Replace_Element --
904 ---------------------
906 procedure Replace_Element (Position : Cursor; By : Element_Type) is
907 X : Element_Access := Position.Node.Element;
909 Position.Node.Element := new Element_Type'(By);
913 ---------------------
914 -- Reverse_Iterate --
915 ---------------------
917 procedure Reverse_Iterate
919 Process : not null access procedure (Position : Cursor))
921 procedure Process_Node (Node : Node_Access);
922 pragma Inline (Process_Node);
924 procedure Local_Reverse_Iterate is
925 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
931 procedure Process_Node (Node : Node_Access) is
933 Process (Cursor'(Container'Unchecked_Access, Node));
936 -- Start of processing for Reverse_Iterate
939 Local_Reverse_Iterate (Container.Tree);
946 function Right (Node : Node_Access) return Node_Access is
955 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
964 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
973 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
975 Node.Parent := Parent;
982 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
991 procedure Update_Element
993 Process : not null access procedure (Element : in out Element_Type))
996 Process (Position.Node.Key.all, Position.Node.Element.all);
1004 (Stream : access Root_Stream_Type'Class;
1007 procedure Process (Node : Node_Access);
1008 pragma Inline (Process);
1010 procedure Iterate is
1011 new Tree_Operations.Generic_Iteration (Process);
1017 procedure Process (Node : Node_Access) is
1019 Key_Type'Output (Stream, Node.Key.all);
1020 Element_Type'Output (Stream, Node.Element.all);
1023 -- Start of processing for Write
1026 Count_Type'Base'Write (Stream, Container.Tree.Length);
1027 Iterate (Container.Tree);
1030 end Ada.Containers.Indefinite_Ordered_Maps;