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 : access Root_Stream_Type'Class) return Node_Access;
966 pragma Inline (Read_Node);
969 new Tree_Operations.Generic_Read (Clear, Read_Node);
976 (Stream : 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
: 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
: 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
;