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-2005, 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, 51 Franklin Street, Fifth Floor, --
24 -- Boston, MA 02110-1301, 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 package body Ada
.Containers
.Ordered_Maps
is
46 -----------------------------
47 -- Node Access Subprograms --
48 -----------------------------
50 -- These subprograms provide a functional interface to access fields
51 -- of a node, and a procedural interface for modifying these values.
53 function Color
(Node
: Node_Access
) return Color_Type
;
54 pragma Inline
(Color
);
56 function Left
(Node
: Node_Access
) return Node_Access
;
59 function Parent
(Node
: Node_Access
) return Node_Access
;
60 pragma Inline
(Parent
);
62 function Right
(Node
: Node_Access
) return Node_Access
;
63 pragma Inline
(Right
);
65 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
);
66 pragma Inline
(Set_Parent
);
68 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
);
69 pragma Inline
(Set_Left
);
71 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
);
72 pragma Inline
(Set_Right
);
74 procedure Set_Color
(Node
: Node_Access
; Color
: Color_Type
);
75 pragma Inline
(Set_Color
);
77 -----------------------
78 -- Local Subprograms --
79 -----------------------
81 function Copy_Node
(Source
: Node_Access
) return Node_Access
;
82 pragma Inline
(Copy_Node
);
84 procedure Free
(X
: in out Node_Access
);
86 function Is_Equal_Node_Node
(L
, R
: Node_Access
) return Boolean;
87 pragma Inline
(Is_Equal_Node_Node
);
89 function Is_Greater_Key_Node
91 Right
: Node_Access
) return Boolean;
92 pragma Inline
(Is_Greater_Key_Node
);
94 function Is_Less_Key_Node
96 Right
: Node_Access
) return Boolean;
97 pragma Inline
(Is_Less_Key_Node
);
99 --------------------------
100 -- Local Instantiations --
101 --------------------------
103 package Tree_Operations
is
104 new Red_Black_Trees
.Generic_Operations
(Tree_Types
);
106 procedure Delete_Tree
is
107 new Tree_Operations
.Generic_Delete_Tree
(Free
);
109 function Copy_Tree
is
110 new Tree_Operations
.Generic_Copy_Tree
(Copy_Node
, Delete_Tree
);
115 new Red_Black_Trees
.Generic_Keys
116 (Tree_Operations
=> Tree_Operations
,
117 Key_Type
=> Key_Type
,
118 Is_Less_Key_Node
=> Is_Less_Key_Node
,
119 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
122 new Tree_Operations
.Generic_Equal
(Is_Equal_Node_Node
);
128 function "<" (Left
, Right
: Cursor
) return Boolean is
130 if Left
.Node
= null then
131 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
134 if Right
.Node
= null then
135 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
138 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
139 "Left cursor of ""<"" is bad");
141 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
142 "Right cursor of ""<"" is bad");
144 return Left
.Node
.Key
< Right
.Node
.Key
;
147 function "<" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
149 if Left
.Node
= null then
150 raise Constraint_Error
with "Left cursor of ""<"" equals No_Element";
153 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
154 "Left cursor of ""<"" is bad");
156 return Left
.Node
.Key
< Right
;
159 function "<" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
161 if Right
.Node
= null then
162 raise Constraint_Error
with "Right cursor of ""<"" equals No_Element";
165 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
166 "Right cursor of ""<"" is bad");
168 return Left
< Right
.Node
.Key
;
175 function "=" (Left
, Right
: Map
) return Boolean is
177 return Is_Equal
(Left
.Tree
, Right
.Tree
);
184 function ">" (Left
, Right
: Cursor
) return Boolean is
186 if Left
.Node
= null then
187 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
190 if Right
.Node
= null then
191 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
194 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
195 "Left cursor of "">"" is bad");
197 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
198 "Right cursor of "">"" is bad");
200 return Right
.Node
.Key
< Left
.Node
.Key
;
203 function ">" (Left
: Cursor
; Right
: Key_Type
) return Boolean is
205 if Left
.Node
= null then
206 raise Constraint_Error
with "Left cursor of "">"" equals No_Element";
209 pragma Assert
(Vet
(Left
.Container
.Tree
, Left
.Node
),
210 "Left cursor of "">"" is bad");
212 return Right
< Left
.Node
.Key
;
215 function ">" (Left
: Key_Type
; Right
: Cursor
) return Boolean is
217 if Right
.Node
= null then
218 raise Constraint_Error
with "Right cursor of "">"" equals No_Element";
221 pragma Assert
(Vet
(Right
.Container
.Tree
, Right
.Node
),
222 "Right cursor of "">"" is bad");
224 return Right
.Node
.Key
< Left
;
232 new Tree_Operations
.Generic_Adjust
(Copy_Tree
);
234 procedure Adjust
(Container
: in out Map
) is
236 Adjust
(Container
.Tree
);
243 function Ceiling
(Container
: Map
; Key
: Key_Type
) return Cursor
is
244 Node
: constant Node_Access
:= Key_Ops
.Ceiling
(Container
.Tree
, Key
);
251 return Cursor
'(Container'Unrestricted_Access, Node);
259 new Tree_Operations.Generic_Clear (Delete_Tree);
261 procedure Clear (Container : in out Map) is
263 Clear (Container.Tree);
270 function Color (Node : Node_Access) return Color_Type is
279 function Contains (Container : Map; Key : Key_Type) return Boolean is
281 return Find (Container, Key) /= No_Element;
288 function Copy_Node (Source : Node_Access) return Node_Access is
289 Target : constant Node_Access :=
290 new Node_Type'(Color
=> Source
.Color
,
292 Element
=> Source
.Element
,
304 procedure Delete
(Container
: in out Map
; Position
: in out Cursor
) is
305 Tree
: Tree_Type
renames Container
.Tree
;
308 if Position
.Node
= null then
309 raise Constraint_Error
with
310 "Position cursor of Delete equals No_Element";
313 if Position
.Container
/= Container
'Unrestricted_Access then
314 raise Program_Error
with
315 "Position cursor of Delete designates wrong map";
318 pragma Assert
(Vet
(Tree
, Position
.Node
),
319 "Position cursor of Delete is bad");
321 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Position
.Node
);
322 Free
(Position
.Node
);
324 Position
.Container
:= null;
327 procedure Delete
(Container
: in out Map
; Key
: Key_Type
) is
328 X
: Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
332 raise Constraint_Error
with "key not in map";
335 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
343 procedure Delete_First
(Container
: in out Map
) is
344 X
: Node_Access
:= Container
.Tree
.First
;
348 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
357 procedure Delete_Last
(Container
: in out Map
) is
358 X
: Node_Access
:= Container
.Tree
.Last
;
362 Tree_Operations
.Delete_Node_Sans_Free
(Container
.Tree
, X
);
371 function Element
(Position
: Cursor
) return Element_Type
is
373 if Position
.Node
= null then
374 raise Constraint_Error
with
375 "Position cursor of function Element equals No_Element";
378 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
379 "Position cursor of function Element is bad");
381 return Position
.Node
.Element
;
384 function Element
(Container
: Map
; Key
: Key_Type
) return Element_Type
is
385 Node
: constant Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
389 raise Constraint_Error
with "key not in map";
395 ---------------------
396 -- Equivalent_Keys --
397 ---------------------
399 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
414 procedure Exclude
(Container
: in out Map
; Key
: Key_Type
) is
415 X
: Node_Access
:= Key_Ops
.Find
(Container
.Tree
, Key
);
419 Tree_Operations
.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
);
436 return Cursor
'(Container'Unrestricted_Access, Node);
443 function First (Container : Map) return Cursor is
444 T : Tree_Type renames Container.Tree;
447 if T.First = null then
451 return Cursor'(Container
'Unrestricted_Access, T
.First
);
458 function First_Element
(Container
: Map
) return Element_Type
is
459 T
: Tree_Type
renames Container
.Tree
;
462 if T
.First
= null then
463 raise Constraint_Error
with "map is empty";
466 return T
.First
.Element
;
473 function First_Key
(Container
: Map
) return Key_Type
is
474 T
: Tree_Type
renames Container
.Tree
;
477 if T
.First
= null then
478 raise Constraint_Error
with "map is empty";
488 function Floor
(Container
: Map
; Key
: Key_Type
) return Cursor
is
489 Node
: constant Node_Access
:= Key_Ops
.Floor
(Container
.Tree
, Key
);
496 return Cursor
'(Container'Unrestricted_Access, Node);
503 procedure Free (X : in out Node_Access) is
504 procedure Deallocate is
505 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
523 function Has_Element (Position : Cursor) return Boolean is
525 return Position /= No_Element;
533 (Container : in out Map;
535 New_Item : Element_Type)
541 Insert (Container, Key, New_Item, Position, Inserted);
544 if Container.Tree.Lock > 0 then
545 raise Program_Error with
546 "attempt to tamper with cursors (map is locked)";
549 Position.Node.Key := Key;
550 Position.Node.Element := New_Item;
555 (Container : in out Map;
557 New_Item : Element_Type;
558 Position : out Cursor;
559 Inserted : out Boolean)
561 function New_Node return Node_Access;
562 pragma Inline (New_Node);
564 procedure Insert_Post is
565 new Key_Ops.Generic_Insert_Post (New_Node);
567 procedure Insert_Sans_Hint is
568 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
574 function New_Node return Node_Access is
576 return new Node_Type'(Key
=> Key
,
578 Color
=> Red_Black_Trees
.Red
,
584 -- Start of processing for Insert
593 Position
.Container
:= Container
'Unrestricted_Access;
597 (Container
: in out Map
;
599 New_Item
: Element_Type
)
605 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
608 raise Constraint_Error
with "key already in map";
617 (Container
: in out Map
;
619 Position
: out Cursor
;
620 Inserted
: out Boolean)
622 function New_Node
return Node_Access
;
623 pragma Inline
(New_Node
);
625 procedure Insert_Post
is
626 new Key_Ops
.Generic_Insert_Post
(New_Node
);
628 procedure Insert_Sans_Hint
is
629 new Key_Ops
.Generic_Conditional_Insert
(Insert_Post
);
635 function New_Node
return Node_Access
is
637 return new Node_Type
'(Key => Key,
639 Color => Red_Black_Trees.Red,
645 -- Start of processing for Insert
654 Position.Container := Container'Unrestricted_Access;
661 function Is_Empty (Container : Map) return Boolean is
663 return Container.Tree.Length = 0;
666 ------------------------
667 -- Is_Equal_Node_Node --
668 ------------------------
670 function Is_Equal_Node_Node
671 (L, R : Node_Access) return Boolean is
673 if L.Key < R.Key then
676 elsif R.Key < L.Key then
680 return L.Element = R.Element;
682 end Is_Equal_Node_Node;
684 -------------------------
685 -- Is_Greater_Key_Node --
686 -------------------------
688 function Is_Greater_Key_Node
690 Right : Node_Access) return Boolean
693 -- k > node same as node < k
695 return Right.Key < Left;
696 end Is_Greater_Key_Node;
698 ----------------------
699 -- Is_Less_Key_Node --
700 ----------------------
702 function Is_Less_Key_Node
704 Right : Node_Access) return Boolean
707 return Left < Right.Key;
708 end Is_Less_Key_Node;
716 Process : not null access procedure (Position : Cursor))
718 procedure Process_Node (Node : Node_Access);
719 pragma Inline (Process_Node);
721 procedure Local_Iterate is
722 new Tree_Operations.Generic_Iteration (Process_Node);
728 procedure Process_Node (Node : Node_Access) is
730 Process (Cursor'(Container
'Unrestricted_Access, Node
));
733 B
: Natural renames Container
.Tree
'Unrestricted_Access.all.Busy
;
735 -- Start of processing for Iterate
741 Local_Iterate
(Container
.Tree
);
755 function Key
(Position
: Cursor
) return Key_Type
is
757 if Position
.Node
= null then
758 raise Constraint_Error
with
759 "Position cursor of function Key equals No_Element";
762 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
763 "Position cursor of function Key is bad");
765 return Position
.Node
.Key
;
772 function Last
(Container
: Map
) return Cursor
is
773 T
: Tree_Type
renames Container
.Tree
;
776 if T
.Last
= null then
780 return Cursor
'(Container'Unrestricted_Access, T.Last);
787 function Last_Element (Container : Map) return Element_Type is
788 T : Tree_Type renames Container.Tree;
791 if T.Last = null then
792 raise Constraint_Error with "map is empty";
795 return T.Last.Element;
802 function Last_Key (Container : Map) return Key_Type is
803 T : Tree_Type renames Container.Tree;
806 if T.Last = null then
807 raise Constraint_Error with "map is empty";
817 function Left (Node : Node_Access) return Node_Access is
826 function Length (Container : Map) return Count_Type is
828 return Container.Tree.Length;
836 new Tree_Operations.Generic_Move (Clear);
838 procedure Move (Target : in out Map; Source : in out Map) is
840 Move (Target => Target.Tree, Source => Source.Tree);
847 procedure Next (Position : in out Cursor) is
849 Position := Next (Position);
852 function Next (Position : Cursor) return Cursor is
854 if Position = No_Element then
858 pragma Assert (Vet (Position.Container.Tree, Position.Node),
859 "Position cursor of Next is bad");
862 Node : constant Node_Access :=
863 Tree_Operations.Next (Position.Node);
870 return Cursor'(Position
.Container
, Node
);
878 function Parent
(Node
: Node_Access
) return Node_Access
is
887 procedure Previous
(Position
: in out Cursor
) is
889 Position
:= Previous
(Position
);
892 function Previous
(Position
: Cursor
) return Cursor
is
894 if Position
= No_Element
then
898 pragma Assert
(Vet
(Position
.Container
.Tree
, Position
.Node
),
899 "Position cursor of Previous is bad");
902 Node
: constant Node_Access
:=
903 Tree_Operations
.Previous
(Position
.Node
);
910 return Cursor
'(Position.Container, Node);
918 procedure Query_Element
920 Process : not null access procedure (Key : Key_Type;
921 Element : Element_Type))
924 if Position.Node = null then
925 raise Constraint_Error with
926 "Position cursor of Query_Element equals No_Element";
929 pragma Assert (Vet (Position.Container.Tree, Position.Node),
930 "Position cursor of Query_Element is bad");
933 T : Tree_Type renames Position.Container.Tree;
935 B : Natural renames T.Busy;
936 L : Natural renames T.Lock;
943 K : Key_Type renames Position.Node.Key;
944 E : Element_Type renames Position.Node.Element;
965 (Stream : not null access Root_Stream_Type'Class;
969 (Stream : access Root_Stream_Type'Class) return Node_Access;
970 pragma Inline (Read_Node);
973 new Tree_Operations.Generic_Read (Clear, Read_Node);
980 (Stream : access Root_Stream_Type'Class) return Node_Access
982 Node : Node_Access := new Node_Type;
984 Key_Type'Read (Stream, Node.Key);
985 Element_Type'Read (Stream, Node.Element);
993 -- Start of processing for Read
996 Read (Stream, Container.Tree);
1000 (Stream : not null access Root_Stream_Type'Class;
1004 raise Program_Error with "attempt to stream map cursor";
1012 (Container : in out Map;
1014 New_Item : Element_Type)
1016 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1020 raise Constraint_Error with "key not in map";
1023 if Container.Tree.Lock > 0 then
1024 raise Program_Error with
1025 "attempt to tamper with cursors (map is locked)";
1029 Node.Element := New_Item;
1032 ---------------------
1033 -- Replace_Element --
1034 ---------------------
1036 procedure Replace_Element
1037 (Container : in out Map;
1039 New_Item : Element_Type)
1042 if Position.Node = null then
1043 raise Constraint_Error with
1044 "Position cursor of Replace_Element equals No_Element";
1047 if Position.Container /= Container'Unrestricted_Access then
1048 raise Program_Error with
1049 "Position cursor of Replace_Element designates wrong map";
1052 if Container.Tree.Lock > 0 then
1053 raise Program_Error with
1054 "attempt to tamper with cursors (map is locked)";
1057 pragma Assert (Vet (Container.Tree, Position.Node),
1058 "Position cursor of Replace_Element is bad");
1060 Position.Node.Element := New_Item;
1061 end Replace_Element;
1063 ---------------------
1064 -- Reverse_Iterate --
1065 ---------------------
1067 procedure Reverse_Iterate
1069 Process : not null access procedure (Position : Cursor))
1071 procedure Process_Node (Node : Node_Access);
1072 pragma Inline (Process_Node);
1074 procedure Local_Reverse_Iterate is
1075 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1081 procedure Process_Node (Node : Node_Access) is
1083 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1086 B
: Natural renames Container
.Tree
'Unrestricted_Access.all.Busy
;
1088 -- Start of processing for Reverse_Iterate
1094 Local_Reverse_Iterate
(Container
.Tree
);
1102 end Reverse_Iterate
;
1108 function Right
(Node
: Node_Access
) return Node_Access
is
1118 (Node
: Node_Access
;
1122 Node
.Color
:= Color
;
1129 procedure Set_Left
(Node
: Node_Access
; Left
: Node_Access
) is
1138 procedure Set_Parent
(Node
: Node_Access
; Parent
: Node_Access
) is
1140 Node
.Parent
:= Parent
;
1147 procedure Set_Right
(Node
: Node_Access
; Right
: Node_Access
) is
1149 Node
.Right
:= Right
;
1152 --------------------
1153 -- Update_Element --
1154 --------------------
1156 procedure Update_Element
1157 (Container
: in out Map
;
1159 Process
: not null access procedure (Key
: Key_Type
;
1160 Element
: in out Element_Type
))
1163 if Position
.Node
= null then
1164 raise Constraint_Error
with
1165 "Position cursor of Update_Element equals No_Element";
1168 if Position
.Container
/= Container
'Unrestricted_Access then
1169 raise Program_Error
with
1170 "Position cursor of Update_Element designates wrong map";
1173 pragma Assert
(Vet
(Container
.Tree
, Position
.Node
),
1174 "Position cursor of Update_Element is bad");
1177 T
: Tree_Type
renames Container
.Tree
;
1179 B
: Natural renames T
.Busy
;
1180 L
: Natural renames T
.Lock
;
1187 K
: Key_Type
renames Position
.Node
.Key
;
1188 E
: Element_Type
renames Position
.Node
.Element
;
1209 (Stream
: not null access Root_Stream_Type
'Class;
1212 procedure Write_Node
1213 (Stream
: access Root_Stream_Type
'Class;
1214 Node
: Node_Access
);
1215 pragma Inline
(Write_Node
);
1218 new Tree_Operations
.Generic_Write
(Write_Node
);
1224 procedure Write_Node
1225 (Stream
: access Root_Stream_Type
'Class;
1229 Key_Type
'Write (Stream
, Node
.Key
);
1230 Element_Type
'Write (Stream
, Node
.Element
);
1233 -- Start of processing for Write
1236 Write
(Stream
, Container
.Tree
);
1240 (Stream
: not null access Root_Stream_Type
'Class;
1244 raise Program_Error
with "attempt to stream map cursor";
1247 end Ada
.Containers
.Ordered_Maps
;