1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S --
9 -- Copyright (C) 2010-2012, 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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 ------------------------------------------------------------------------------
28 with Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Operations
;
30 (Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Operations
);
32 with Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Keys
;
33 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Keys
);
35 with System
; use type System
.Address
;
37 package body Ada
.Containers
.Formal_Ordered_Maps
is
39 -----------------------------
40 -- Node Access Subprograms --
41 -----------------------------
43 -- These subprograms provide a functional interface to access fields
44 -- of a node, and a procedural interface for modifying these values.
47 (Node
: Node_Type
) return Ada
.Containers
.Red_Black_Trees
.Color_Type
;
48 pragma Inline
(Color
);
50 function Left_Son
(Node
: Node_Type
) return Count_Type
;
53 function Parent
(Node
: Node_Type
) return Count_Type
;
54 pragma Inline
(Parent
);
56 function Right_Son
(Node
: Node_Type
) return Count_Type
;
57 pragma Inline
(Right
);
60 (Node
: in out Node_Type
;
61 Color
: Ada
.Containers
.Red_Black_Trees
.Color_Type
);
62 pragma Inline
(Set_Color
);
64 procedure Set_Left
(Node
: in out Node_Type
; Left
: Count_Type
);
65 pragma Inline
(Set_Left
);
67 procedure Set_Right
(Node
: in out Node_Type
; Right
: Count_Type
);
68 pragma Inline
(Set_Right
);
70 procedure Set_Parent
(Node
: in out Node_Type
; Parent
: Count_Type
);
71 pragma Inline
(Set_Parent
);
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 -- All need comments ???
80 with procedure Set_Element
(Node
: in out Node_Type
);
81 procedure Generic_Allocate
82 (Tree
: in out Tree_Types
.Tree_Type
'Class;
83 Node
: out Count_Type
);
85 procedure Free
(Tree
: in out Map
; X
: Count_Type
);
87 function Is_Greater_Key_Node
89 Right
: Node_Type
) return Boolean;
90 pragma Inline
(Is_Greater_Key_Node
);
92 function Is_Less_Key_Node
94 Right
: Node_Type
) return Boolean;
95 pragma Inline
(Is_Less_Key_Node
);
97 --------------------------
98 -- Local Instantiations --
99 --------------------------
101 package Tree_Operations
is
102 new Red_Black_Trees
.Generic_Bounded_Operations
103 (Tree_Types
=> Tree_Types
,
110 new Red_Black_Trees
.Generic_Bounded_Keys
111 (Tree_Operations
=> Tree_Operations
,
112 Key_Type
=> Key_Type
,
113 Is_Less_Key_Node
=> Is_Less_Key_Node
,
114 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
120 function "=" (Left
, Right
: Map
) return Boolean is
126 if Length
(Left
) /= Length
(Right
) then
130 if Is_Empty
(Left
) then
134 Lst
:= Next
(Left
, Last
(Left
).Node
);
136 Node
:= First
(Left
).Node
;
137 while Node
/= Lst
loop
138 ENode
:= Find
(Right
, Left
.Nodes
(Node
).Key
).Node
;
141 Left
.Nodes
(Node
).Element
/= Right
.Nodes
(ENode
).Element
146 Node
:= Next
(Left
, Node
);
156 procedure Assign
(Target
: in out Map
; Source
: Map
) is
157 procedure Append_Element
(Source_Node
: Count_Type
);
159 procedure Append_Elements
is
160 new Tree_Operations
.Generic_Iteration
(Append_Element
);
166 procedure Append_Element
(Source_Node
: Count_Type
) is
167 SN
: Node_Type
renames Source
.Nodes
(Source_Node
);
169 procedure Set_Element
(Node
: in out Node_Type
);
170 pragma Inline
(Set_Element
);
172 function New_Node
return Count_Type
;
173 pragma Inline
(New_Node
);
175 procedure Insert_Post
is new Key_Ops
.Generic_Insert_Post
(New_Node
);
177 procedure Unconditional_Insert_Sans_Hint
is
178 new Key_Ops
.Generic_Unconditional_Insert
(Insert_Post
);
180 procedure Unconditional_Insert_Avec_Hint
is
181 new Key_Ops
.Generic_Unconditional_Insert_With_Hint
183 Unconditional_Insert_Sans_Hint
);
185 procedure Allocate
is new Generic_Allocate
(Set_Element
);
191 function New_Node
return Count_Type
is
194 Allocate
(Target
, Result
);
202 procedure Set_Element
(Node
: in out Node_Type
) is
205 Node
.Element
:= SN
.Element
;
208 Target_Node
: Count_Type
;
210 -- Start of processing for Append_Element
213 Unconditional_Insert_Avec_Hint
217 Node
=> Target_Node
);
220 -- Start of processing for Assign
223 if Target
'Address = Source
'Address then
227 if Target
.Capacity
< Length
(Source
) then
228 raise Storage_Error
with "not enough capacity"; -- SE or CE? ???
231 Tree_Operations
.Clear_Tree
(Target
);
232 Append_Elements
(Source
);
239 function Ceiling
(Container
: Map
; Key
: Key_Type
) return Cursor
is
240 Node
: constant Count_Type
:= Key_Ops
.Ceiling
(Container
, Key
);
247 return (Node
=> Node
);
254 procedure Clear
(Container
: in out Map
) is
256 Tree_Operations
.Clear_Tree
(Container
);
263 function Color
(Node
: Node_Type
) return Color_Type
is
272 function Contains
(Container
: Map
; Key
: Key_Type
) return Boolean is
274 return Find
(Container
, Key
) /= No_Element
;
281 function Copy
(Source
: Map
; Capacity
: Count_Type
:= 0) return Map
is
282 Node
: Count_Type
:= 1;
286 return Target
: Map
(Count_Type
'Max (Source
.Capacity
, Capacity
)) do
287 if Length
(Source
) > 0 then
288 Target
.Length
:= Source
.Length
;
289 Target
.Root
:= Source
.Root
;
290 Target
.First
:= Source
.First
;
291 Target
.Last
:= Source
.Last
;
292 Target
.Free
:= Source
.Free
;
294 while Node
<= Source
.Capacity
loop
295 Target
.Nodes
(Node
).Element
:=
296 Source
.Nodes
(Node
).Element
;
297 Target
.Nodes
(Node
).Key
:=
298 Source
.Nodes
(Node
).Key
;
299 Target
.Nodes
(Node
).Parent
:=
300 Source
.Nodes
(Node
).Parent
;
301 Target
.Nodes
(Node
).Left
:=
302 Source
.Nodes
(Node
).Left
;
303 Target
.Nodes
(Node
).Right
:=
304 Source
.Nodes
(Node
).Right
;
305 Target
.Nodes
(Node
).Color
:=
306 Source
.Nodes
(Node
).Color
;
307 Target
.Nodes
(Node
).Has_Element
:=
308 Source
.Nodes
(Node
).Has_Element
;
312 while Node
<= Target
.Capacity
loop
314 Formal_Ordered_Maps
.Free
(Tree
=> Target
, X
=> N
);
325 procedure Delete
(Container
: in out Map
; Position
: in out Cursor
) is
327 if not Has_Element
(Container
, Position
) then
328 raise Constraint_Error
with
329 "Position cursor of Delete has no element";
332 pragma Assert
(Vet
(Container
, Position
.Node
),
333 "Position cursor of Delete is bad");
335 Tree_Operations
.Delete_Node_Sans_Free
(Container
,
337 Formal_Ordered_Maps
.Free
(Container
, Position
.Node
);
340 procedure Delete
(Container
: in out Map
; Key
: Key_Type
) is
341 X
: constant Node_Access
:= Key_Ops
.Find
(Container
, Key
);
345 raise Constraint_Error
with "key not in map";
348 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
349 Formal_Ordered_Maps
.Free
(Container
, X
);
356 procedure Delete_First
(Container
: in out Map
) is
357 X
: constant Node_Access
:= First
(Container
).Node
;
360 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
361 Formal_Ordered_Maps
.Free
(Container
, X
);
369 procedure Delete_Last
(Container
: in out Map
) is
370 X
: constant Node_Access
:= Last
(Container
).Node
;
373 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
374 Formal_Ordered_Maps
.Free
(Container
, X
);
382 function Element
(Container
: Map
; Position
: Cursor
) return Element_Type
is
384 if not Has_Element
(Container
, Position
) then
385 raise Constraint_Error
with
386 "Position cursor of function Element has no element";
389 pragma Assert
(Vet
(Container
, Position
.Node
),
390 "Position cursor of function Element is bad");
392 return Container
.Nodes
(Position
.Node
).Element
;
396 function Element
(Container
: Map
; Key
: Key_Type
) return Element_Type
is
397 Node
: constant Node_Access
:= Find
(Container
, Key
).Node
;
401 raise Constraint_Error
with "key not in map";
404 return Container
.Nodes
(Node
).Element
;
407 ---------------------
408 -- Equivalent_Keys --
409 ---------------------
411 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
426 procedure Exclude
(Container
: in out Map
; Key
: Key_Type
) is
427 X
: constant Node_Access
:= Key_Ops
.Find
(Container
, Key
);
430 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
431 Formal_Ordered_Maps
.Free
(Container
, X
);
439 function Find
(Container
: Map
; Key
: Key_Type
) return Cursor
is
440 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
447 return (Node
=> Node
);
454 function First
(Container
: Map
) return Cursor
is
456 if Length
(Container
) = 0 then
460 return (Node
=> Container
.First
);
467 function First_Element
(Container
: Map
) return Element_Type
is
469 if Is_Empty
(Container
) then
470 raise Constraint_Error
with "map is empty";
473 return Container
.Nodes
(First
(Container
).Node
).Element
;
480 function First_Key
(Container
: Map
) return Key_Type
is
482 if Is_Empty
(Container
) then
483 raise Constraint_Error
with "map is empty";
486 return Container
.Nodes
(First
(Container
).Node
).Key
;
493 function Floor
(Container
: Map
; Key
: Key_Type
) return Cursor
is
494 Node
: constant Count_Type
:= Key_Ops
.Floor
(Container
, Key
);
501 return (Node
=> Node
);
513 Tree
.Nodes
(X
).Has_Element
:= False;
514 Tree_Operations
.Free
(Tree
, X
);
517 ----------------------
518 -- Generic_Allocate --
519 ----------------------
521 procedure Generic_Allocate
522 (Tree
: in out Tree_Types
.Tree_Type
'Class;
523 Node
: out Count_Type
)
525 procedure Allocate
is
526 new Tree_Operations
.Generic_Allocate
(Set_Element
);
528 Allocate
(Tree
, Node
);
529 Tree
.Nodes
(Node
).Has_Element
:= True;
530 end Generic_Allocate
;
536 function Has_Element
(Container
: Map
; Position
: Cursor
) return Boolean is
538 if Position
.Node
= 0 then
542 return Container
.Nodes
(Position
.Node
).Has_Element
;
550 (Container
: in out Map
;
552 New_Item
: Element_Type
)
558 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
561 if Container
.Lock
> 0 then
562 raise Program_Error
with
563 "attempt to tamper with cursors (map is locked)";
567 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
570 N
.Element
:= New_Item
;
576 (Container
: in out Map
;
578 New_Item
: Element_Type
;
579 Position
: out Cursor
;
580 Inserted
: out Boolean)
582 function New_Node
return Node_Access
;
585 procedure Insert_Post
is
586 new Key_Ops
.Generic_Insert_Post
(New_Node
);
588 procedure Insert_Sans_Hint
is
589 new Key_Ops
.Generic_Conditional_Insert
(Insert_Post
);
595 function New_Node
return Node_Access
is
596 procedure Initialize
(Node
: in out Node_Type
);
597 procedure Allocate_Node
is new Generic_Allocate
(Initialize
);
599 procedure Initialize
(Node
: in out Node_Type
) is
602 Node
.Element
:= New_Item
;
608 Allocate_Node
(Container
, X
);
612 -- Start of processing for Insert
623 (Container
: in out Map
;
625 New_Item
: Element_Type
)
631 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
634 raise Constraint_Error
with "key already in map";
643 (Container
: in out Map
;
645 Position
: out Cursor
;
646 Inserted
: out Boolean)
648 function New_Node
return Node_Access
;
650 procedure Insert_Post
is
651 new Key_Ops
.Generic_Insert_Post
(New_Node
);
653 procedure Insert_Sans_Hint
is
654 new Key_Ops
.Generic_Conditional_Insert
(Insert_Post
);
660 function New_Node
return Node_Access
is
661 procedure Initialize
(Node
: in out Node_Type
);
662 procedure Allocate_Node
is new Generic_Allocate
(Initialize
);
668 procedure Initialize
(Node
: in out Node_Type
) is
675 -- Start of processing for New_Node
678 Allocate_Node
(Container
, X
);
682 -- Start of processing for Insert
685 Insert_Sans_Hint
(Container
, Key
, Position
.Node
, Inserted
);
692 function Is_Empty
(Container
: Map
) return Boolean is
694 return Length
(Container
) = 0;
697 -------------------------
698 -- Is_Greater_Key_Node --
699 -------------------------
701 function Is_Greater_Key_Node
703 Right
: Node_Type
) return Boolean
706 -- k > node same as node < k
708 return Right
.Key
< Left
;
709 end Is_Greater_Key_Node
;
711 ----------------------
712 -- Is_Less_Key_Node --
713 ----------------------
715 function Is_Less_Key_Node
717 Right
: Node_Type
) return Boolean
720 return Left
< Right
.Key
;
721 end Is_Less_Key_Node
;
730 not null access procedure (Container
: Map
; Position
: Cursor
))
732 procedure Process_Node
(Node
: Node_Access
);
733 pragma Inline
(Process_Node
);
735 procedure Local_Iterate
is
736 new Tree_Operations
.Generic_Iteration
(Process_Node
);
742 procedure Process_Node
(Node
: Node_Access
) is
744 Process
(Container
, (Node
=> Node
));
747 B
: Natural renames Container
'Unrestricted_Access.Busy
;
749 -- Start of processing for Iterate
755 Local_Iterate
(Container
);
769 function Key
(Container
: Map
; Position
: Cursor
) return Key_Type
is
771 if not Has_Element
(Container
, Position
) then
772 raise Constraint_Error
with
773 "Position cursor of function Key has no element";
776 pragma Assert
(Vet
(Container
, Position
.Node
),
777 "Position cursor of function Key is bad");
779 return Container
.Nodes
(Position
.Node
).Key
;
786 function Last
(Container
: Map
) return Cursor
is
788 if Length
(Container
) = 0 then
792 return (Node
=> Container
.Last
);
799 function Last_Element
(Container
: Map
) return Element_Type
is
801 if Is_Empty
(Container
) then
802 raise Constraint_Error
with "map is empty";
805 return Container
.Nodes
(Last
(Container
).Node
).Element
;
812 function Last_Key
(Container
: Map
) return Key_Type
is
814 if Is_Empty
(Container
) then
815 raise Constraint_Error
with "map is empty";
818 return Container
.Nodes
(Last
(Container
).Node
).Key
;
825 function Left
(Container
: Map
; Position
: Cursor
) return Map
is
826 Curs
: Cursor
:= Position
;
827 C
: Map
(Container
.Capacity
) := Copy
(Container
, Container
.Capacity
);
831 if Curs
= No_Element
then
835 if not Has_Element
(Container
, Curs
) then
836 raise Constraint_Error
;
839 while Curs
.Node
/= 0 loop
842 Curs
:= Next
(Container
, (Node
=> Node
));
852 function Left_Son
(Node
: Node_Type
) return Count_Type
is
861 function Length
(Container
: Map
) return Count_Type
is
863 return Container
.Length
;
870 procedure Move
(Target
: in out Map
; Source
: in out Map
) is
871 NN
: Tree_Types
.Nodes_Type
renames Source
.Nodes
;
875 if Target
'Address = Source
'Address then
879 if Target
.Capacity
< Length
(Source
) then
880 raise Constraint_Error
with -- ???
881 "Source length exceeds Target capacity";
884 if Source
.Busy
> 0 then
885 raise Program_Error
with
886 "attempt to tamper with cursors of Source (list is busy)";
892 X
:= First
(Source
).Node
;
895 -- Here we insert a copy of the source element into the target, and
896 -- then delete the element from the source. Another possibility is
897 -- that delete it first (and hang onto its index), then insert it.
900 Insert
(Target
, NN
(X
).Key
, NN
(X
).Element
); -- optimize???
902 Tree_Operations
.Delete_Node_Sans_Free
(Source
, X
);
903 Formal_Ordered_Maps
.Free
(Source
, X
);
911 procedure Next
(Container
: Map
; Position
: in out Cursor
) is
913 Position
:= Next
(Container
, Position
);
916 function Next
(Container
: Map
; Position
: Cursor
) return Cursor
is
918 if Position
= No_Element
then
922 if not Has_Element
(Container
, Position
) then
923 raise Constraint_Error
;
926 pragma Assert
(Vet
(Container
, Position
.Node
),
927 "bad cursor in Next");
929 return (Node
=> Tree_Operations
.Next
(Container
, Position
.Node
));
936 function Overlap
(Left
, Right
: Map
) return Boolean is
938 if Length
(Left
) = 0 or Length
(Right
) = 0 then
943 L_Node
: Count_Type
:= First
(Left
).Node
;
944 R_Node
: Count_Type
:= First
(Right
).Node
;
945 L_Last
: constant Count_Type
:= Next
(Left
, Last
(Left
).Node
);
946 R_Last
: constant Count_Type
:= Next
(Right
, Last
(Right
).Node
);
949 if Left
'Address = Right
'Address then
955 or else R_Node
= R_Last
960 if Left
.Nodes
(L_Node
).Key
< Right
.Nodes
(R_Node
).Key
then
961 L_Node
:= Next
(Left
, L_Node
);
963 elsif Right
.Nodes
(R_Node
).Key
< Left
.Nodes
(L_Node
).Key
then
964 R_Node
:= Next
(Right
, R_Node
);
977 function Parent
(Node
: Node_Type
) return Count_Type
is
986 procedure Previous
(Container
: Map
; Position
: in out Cursor
) is
988 Position
:= Previous
(Container
, Position
);
991 function Previous
(Container
: Map
; Position
: Cursor
) return Cursor
is
993 if Position
= No_Element
then
997 if not Has_Element
(Container
, Position
) then
998 raise Constraint_Error
;
1001 pragma Assert
(Vet
(Container
, Position
.Node
),
1002 "bad cursor in Previous");
1005 Node
: constant Count_Type
:=
1006 Tree_Operations
.Previous
(Container
, Position
.Node
);
1013 return (Node
=> Node
);
1021 procedure Query_Element
1022 (Container
: in out Map
;
1024 Process
: not null access procedure (Key
: Key_Type
;
1025 Element
: Element_Type
))
1028 if not Has_Element
(Container
, Position
) then
1029 raise Constraint_Error
with
1030 "Position cursor of Query_Element has no element";
1033 pragma Assert
(Vet
(Container
, Position
.Node
),
1034 "Position cursor of Query_Element is bad");
1037 B
: Natural renames Container
.Busy
;
1038 L
: Natural renames Container
.Lock
;
1045 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
1046 K
: Key_Type
renames N
.Key
;
1047 E
: Element_Type
renames N
.Element
;
1068 (Stream
: not null access Root_Stream_Type
'Class;
1069 Container
: out Map
)
1071 procedure Read_Element
(Node
: in out Node_Type
);
1072 pragma Inline
(Read_Element
);
1074 procedure Allocate
is
1075 new Generic_Allocate
(Read_Element
);
1077 procedure Read_Elements
is
1078 new Tree_Operations
.Generic_Read
(Allocate
);
1084 procedure Read_Element
(Node
: in out Node_Type
) is
1086 Key_Type
'Read (Stream
, Node
.Key
);
1087 Element_Type
'Read (Stream
, Node
.Element
);
1090 -- Start of processing for Read
1093 Read_Elements
(Stream
, Container
);
1097 (Stream
: not null access Root_Stream_Type
'Class;
1101 raise Program_Error
with "attempt to stream map cursor";
1109 (Container
: in out Map
;
1111 New_Item
: Element_Type
)
1115 Node
: constant Node_Access
:= Key_Ops
.Find
(Container
, Key
);
1119 raise Constraint_Error
with "key not in map";
1122 if Container
.Lock
> 0 then
1123 raise Program_Error
with
1124 "attempt to tamper with cursors (map is locked)";
1128 N
: Node_Type
renames Container
.Nodes
(Node
);
1131 N
.Element
:= New_Item
;
1136 ---------------------
1137 -- Replace_Element --
1138 ---------------------
1140 procedure Replace_Element
1141 (Container
: in out Map
;
1143 New_Item
: Element_Type
)
1146 if not Has_Element
(Container
, Position
) then
1147 raise Constraint_Error
with
1148 "Position cursor of Replace_Element has no element";
1151 if Container
.Lock
> 0 then
1152 raise Program_Error
with
1153 "attempt to tamper with cursors (map is locked)";
1156 pragma Assert
(Vet
(Container
, Position
.Node
),
1157 "Position cursor of Replace_Element is bad");
1159 Container
.Nodes
(Position
.Node
).Element
:= New_Item
;
1160 end Replace_Element
;
1162 ---------------------
1163 -- Reverse_Iterate --
1164 ---------------------
1166 procedure Reverse_Iterate
1168 Process
: not null access procedure (Container
: Map
;
1171 procedure Process_Node
(Node
: Node_Access
);
1172 pragma Inline
(Process_Node
);
1174 procedure Local_Reverse_Iterate
is
1175 new Tree_Operations
.Generic_Reverse_Iteration
(Process_Node
);
1181 procedure Process_Node
(Node
: Node_Access
) is
1183 Process
(Container
, (Node
=> Node
));
1186 B
: Natural renames Container
'Unrestricted_Access.Busy
;
1188 -- Start of processing for Reverse_Iterate
1194 Local_Reverse_Iterate
(Container
);
1202 end Reverse_Iterate
;
1208 function Right
(Container
: Map
; Position
: Cursor
) return Map
is
1209 Curs
: Cursor
:= First
(Container
);
1210 C
: Map
(Container
.Capacity
) := Copy
(Container
, Container
.Capacity
);
1214 if Curs
= No_Element
then
1219 if Position
/= No_Element
and not Has_Element
(Container
, Position
) then
1220 raise Constraint_Error
;
1223 while Curs
.Node
/= Position
.Node
loop
1226 Curs
:= Next
(Container
, (Node
=> Node
));
1236 function Right_Son
(Node
: Node_Type
) return Count_Type
is
1245 procedure Set_Color
(Node
: in out Node_Type
; Color
: Color_Type
) is
1247 Node
.Color
:= Color
;
1254 procedure Set_Left
(Node
: in out Node_Type
; Left
: Count_Type
) is
1263 procedure Set_Parent
(Node
: in out Node_Type
; Parent
: Count_Type
) is
1265 Node
.Parent
:= Parent
;
1272 procedure Set_Right
(Node
: in out Node_Type
; Right
: Count_Type
) is
1274 Node
.Right
:= Right
;
1281 function Strict_Equal
(Left
, Right
: Map
) return Boolean is
1282 LNode
: Count_Type
:= First
(Left
).Node
;
1283 RNode
: Count_Type
:= First
(Right
).Node
;
1286 if Length
(Left
) /= Length
(Right
) then
1290 while LNode
= RNode
loop
1295 if Left
.Nodes
(LNode
).Element
/= Right
.Nodes
(RNode
).Element
1296 or else Left
.Nodes
(LNode
).Key
/= Right
.Nodes
(RNode
).Key
1301 LNode
:= Next
(Left
, LNode
);
1302 RNode
:= Next
(Right
, RNode
);
1308 --------------------
1309 -- Update_Element --
1310 --------------------
1312 procedure Update_Element
1313 (Container
: in out Map
;
1315 Process
: not null access procedure (Key
: Key_Type
;
1316 Element
: in out Element_Type
))
1319 if not Has_Element
(Container
, Position
) then
1320 raise Constraint_Error
with
1321 "Position cursor of Update_Element has no element";
1324 pragma Assert
(Vet
(Container
, Position
.Node
),
1325 "Position cursor of Update_Element is bad");
1328 B
: Natural renames Container
.Busy
;
1329 L
: Natural renames Container
.Lock
;
1336 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
1337 K
: Key_Type
renames N
.Key
;
1338 E
: Element_Type
renames N
.Element
;
1359 (Stream
: not null access Root_Stream_Type
'Class;
1362 procedure Write_Node
1363 (Stream
: not null access Root_Stream_Type
'Class;
1365 pragma Inline
(Write_Node
);
1367 procedure Write_Nodes
is
1368 new Tree_Operations
.Generic_Write
(Write_Node
);
1374 procedure Write_Node
1375 (Stream
: not null access Root_Stream_Type
'Class;
1379 Key_Type
'Write (Stream
, Node
.Key
);
1380 Element_Type
'Write (Stream
, Node
.Element
);
1383 -- Start of processing for Write
1386 Write_Nodes
(Stream
, Container
);
1390 (Stream
: not null access Root_Stream_Type
'Class;
1394 raise Program_Error
with "attempt to stream map cursor";
1397 end Ada
.Containers
.Formal_Ordered_Maps
;