|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
|
4 -- --
|
|
|
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 --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2004-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
17 -- --
|
|
|
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. --
|
|
|
21 -- --
|
|
|
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 -- --
|
|
|
27 -- This unit was originally developed by Matthew J Heaney. --
|
|
|
28 ------------------------------------------------------------------------------
|
|
|
29
|
|
|
30 with Ada.Unchecked_Deallocation;
|
|
|
31
|
|
|
32 with Ada.Containers.Helpers; use Ada.Containers.Helpers;
|
|
|
33
|
|
|
34 with Ada.Containers.Red_Black_Trees.Generic_Operations;
|
|
|
35 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
|
|
|
36
|
|
|
37 with Ada.Containers.Red_Black_Trees.Generic_Keys;
|
|
|
38 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
|
|
|
39
|
|
|
40 with System; use type System.Address;
|
|
|
41
|
|
|
42 package body Ada.Containers.Ordered_Maps is
|
|
|
43
|
|
|
44 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
|
|
|
45 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
|
|
|
46 -- See comment in Ada.Containers.Helpers
|
|
|
47
|
|
|
48 -----------------------------
|
|
|
49 -- Node Access Subprograms --
|
|
|
50 -----------------------------
|
|
|
51
|
|
|
52 -- These subprograms provide a functional interface to access fields
|
|
|
53 -- of a node, and a procedural interface for modifying these values.
|
|
|
54
|
|
|
55 function Color (Node : Node_Access) return Color_Type;
|
|
|
56 pragma Inline (Color);
|
|
|
57
|
|
|
58 function Left (Node : Node_Access) return Node_Access;
|
|
|
59 pragma Inline (Left);
|
|
|
60
|
|
|
61 function Parent (Node : Node_Access) return Node_Access;
|
|
|
62 pragma Inline (Parent);
|
|
|
63
|
|
|
64 function Right (Node : Node_Access) return Node_Access;
|
|
|
65 pragma Inline (Right);
|
|
|
66
|
|
|
67 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
|
|
|
68 pragma Inline (Set_Parent);
|
|
|
69
|
|
|
70 procedure Set_Left (Node : Node_Access; Left : Node_Access);
|
|
|
71 pragma Inline (Set_Left);
|
|
|
72
|
|
|
73 procedure Set_Right (Node : Node_Access; Right : Node_Access);
|
|
|
74 pragma Inline (Set_Right);
|
|
|
75
|
|
|
76 procedure Set_Color (Node : Node_Access; Color : Color_Type);
|
|
|
77 pragma Inline (Set_Color);
|
|
|
78
|
|
|
79 -----------------------
|
|
|
80 -- Local Subprograms --
|
|
|
81 -----------------------
|
|
|
82
|
|
|
83 function Copy_Node (Source : Node_Access) return Node_Access;
|
|
|
84 pragma Inline (Copy_Node);
|
|
|
85
|
|
|
86 procedure Free (X : in out Node_Access);
|
|
|
87
|
|
|
88 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
|
|
|
89 pragma Inline (Is_Equal_Node_Node);
|
|
|
90
|
|
|
91 function Is_Greater_Key_Node
|
|
|
92 (Left : Key_Type;
|
|
|
93 Right : Node_Access) return Boolean;
|
|
|
94 pragma Inline (Is_Greater_Key_Node);
|
|
|
95
|
|
|
96 function Is_Less_Key_Node
|
|
|
97 (Left : Key_Type;
|
|
|
98 Right : Node_Access) return Boolean;
|
|
|
99 pragma Inline (Is_Less_Key_Node);
|
|
|
100
|
|
|
101 --------------------------
|
|
|
102 -- Local Instantiations --
|
|
|
103 --------------------------
|
|
|
104
|
|
|
105 package Tree_Operations is
|
|
|
106 new Red_Black_Trees.Generic_Operations (Tree_Types);
|
|
|
107
|
|
|
108 procedure Delete_Tree is
|
|
|
109 new Tree_Operations.Generic_Delete_Tree (Free);
|
|
|
110
|
|
|
111 function Copy_Tree is
|
|
|
112 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
|
|
|
113
|
|
|
114 use Tree_Operations;
|
|
|
115
|
|
|
116 package Key_Ops is
|
|
|
117 new Red_Black_Trees.Generic_Keys
|
|
|
118 (Tree_Operations => Tree_Operations,
|
|
|
119 Key_Type => Key_Type,
|
|
|
120 Is_Less_Key_Node => Is_Less_Key_Node,
|
|
|
121 Is_Greater_Key_Node => Is_Greater_Key_Node);
|
|
|
122
|
|
|
123 function Is_Equal is
|
|
|
124 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
|
|
|
125
|
|
|
126 ---------
|
|
|
127 -- "<" --
|
|
|
128 ---------
|
|
|
129
|
|
|
130 function "<" (Left, Right : Cursor) return Boolean is
|
|
|
131 begin
|
|
|
132 if Checks and then Left.Node = null then
|
|
|
133 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
|
|
|
134 end if;
|
|
|
135
|
|
|
136 if Checks and then Right.Node = null then
|
|
|
137 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
|
|
|
138 end if;
|
|
|
139
|
|
|
140 pragma Assert (Vet (Left.Container.Tree, Left.Node),
|
|
|
141 "Left cursor of ""<"" is bad");
|
|
|
142
|
|
|
143 pragma Assert (Vet (Right.Container.Tree, Right.Node),
|
|
|
144 "Right cursor of ""<"" is bad");
|
|
|
145
|
|
|
146 return Left.Node.Key < Right.Node.Key;
|
|
|
147 end "<";
|
|
|
148
|
|
|
149 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
|
|
|
150 begin
|
|
|
151 if Checks and then Left.Node = null then
|
|
|
152 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
|
|
|
153 end if;
|
|
|
154
|
|
|
155 pragma Assert (Vet (Left.Container.Tree, Left.Node),
|
|
|
156 "Left cursor of ""<"" is bad");
|
|
|
157
|
|
|
158 return Left.Node.Key < Right;
|
|
|
159 end "<";
|
|
|
160
|
|
|
161 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
|
|
|
162 begin
|
|
|
163 if Checks and then Right.Node = null then
|
|
|
164 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
|
|
|
165 end if;
|
|
|
166
|
|
|
167 pragma Assert (Vet (Right.Container.Tree, Right.Node),
|
|
|
168 "Right cursor of ""<"" is bad");
|
|
|
169
|
|
|
170 return Left < Right.Node.Key;
|
|
|
171 end "<";
|
|
|
172
|
|
|
173 ---------
|
|
|
174 -- "=" --
|
|
|
175 ---------
|
|
|
176
|
|
|
177 function "=" (Left, Right : Map) return Boolean is
|
|
|
178 begin
|
|
|
179 return Is_Equal (Left.Tree, Right.Tree);
|
|
|
180 end "=";
|
|
|
181
|
|
|
182 ---------
|
|
|
183 -- ">" --
|
|
|
184 ---------
|
|
|
185
|
|
|
186 function ">" (Left, Right : Cursor) return Boolean is
|
|
|
187 begin
|
|
|
188 if Checks and then Left.Node = null then
|
|
|
189 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
|
|
|
190 end if;
|
|
|
191
|
|
|
192 if Checks and then Right.Node = null then
|
|
|
193 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
|
|
|
194 end if;
|
|
|
195
|
|
|
196 pragma Assert (Vet (Left.Container.Tree, Left.Node),
|
|
|
197 "Left cursor of "">"" is bad");
|
|
|
198
|
|
|
199 pragma Assert (Vet (Right.Container.Tree, Right.Node),
|
|
|
200 "Right cursor of "">"" is bad");
|
|
|
201
|
|
|
202 return Right.Node.Key < Left.Node.Key;
|
|
|
203 end ">";
|
|
|
204
|
|
|
205 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
|
|
|
206 begin
|
|
|
207 if Checks and then Left.Node = null then
|
|
|
208 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
|
|
|
209 end if;
|
|
|
210
|
|
|
211 pragma Assert (Vet (Left.Container.Tree, Left.Node),
|
|
|
212 "Left cursor of "">"" is bad");
|
|
|
213
|
|
|
214 return Right < Left.Node.Key;
|
|
|
215 end ">";
|
|
|
216
|
|
|
217 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
|
|
|
218 begin
|
|
|
219 if Checks and then Right.Node = null then
|
|
|
220 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
|
|
|
221 end if;
|
|
|
222
|
|
|
223 pragma Assert (Vet (Right.Container.Tree, Right.Node),
|
|
|
224 "Right cursor of "">"" is bad");
|
|
|
225
|
|
|
226 return Right.Node.Key < Left;
|
|
|
227 end ">";
|
|
|
228
|
|
|
229 ------------
|
|
|
230 -- Adjust --
|
|
|
231 ------------
|
|
|
232
|
|
|
233 procedure Adjust is
|
|
|
234 new Tree_Operations.Generic_Adjust (Copy_Tree);
|
|
|
235
|
|
|
236 procedure Adjust (Container : in out Map) is
|
|
|
237 begin
|
|
|
238 Adjust (Container.Tree);
|
|
|
239 end Adjust;
|
|
|
240
|
|
|
241 ------------
|
|
|
242 -- Assign --
|
|
|
243 ------------
|
|
|
244
|
|
|
245 procedure Assign (Target : in out Map; Source : Map) is
|
|
|
246 procedure Insert_Item (Node : Node_Access);
|
|
|
247 pragma Inline (Insert_Item);
|
|
|
248
|
|
|
249 procedure Insert_Items is
|
|
|
250 new Tree_Operations.Generic_Iteration (Insert_Item);
|
|
|
251
|
|
|
252 -----------------
|
|
|
253 -- Insert_Item --
|
|
|
254 -----------------
|
|
|
255
|
|
|
256 procedure Insert_Item (Node : Node_Access) is
|
|
|
257 begin
|
|
|
258 Target.Insert (Key => Node.Key, New_Item => Node.Element);
|
|
|
259 end Insert_Item;
|
|
|
260
|
|
|
261 -- Start of processing for Assign
|
|
|
262
|
|
|
263 begin
|
|
|
264 if Target'Address = Source'Address then
|
|
|
265 return;
|
|
|
266 end if;
|
|
|
267
|
|
|
268 Target.Clear;
|
|
|
269 Insert_Items (Source.Tree);
|
|
|
270 end Assign;
|
|
|
271
|
|
|
272 -------------
|
|
|
273 -- Ceiling --
|
|
|
274 -------------
|
|
|
275
|
|
|
276 function Ceiling (Container : Map; Key : Key_Type) return Cursor is
|
|
|
277 Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
|
|
|
278
|
|
|
279 begin
|
|
|
280 if Node = null then
|
|
|
281 return No_Element;
|
|
|
282 end if;
|
|
|
283
|
|
|
284 return Cursor'(Container'Unrestricted_Access, Node);
|
|
|
285 end Ceiling;
|
|
|
286
|
|
|
287 -----------
|
|
|
288 -- Clear --
|
|
|
289 -----------
|
|
|
290
|
|
|
291 procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree);
|
|
|
292
|
|
|
293 procedure Clear (Container : in out Map) is
|
|
|
294 begin
|
|
|
295 Clear (Container.Tree);
|
|
|
296 end Clear;
|
|
|
297
|
|
|
298 -----------
|
|
|
299 -- Color --
|
|
|
300 -----------
|
|
|
301
|
|
|
302 function Color (Node : Node_Access) return Color_Type is
|
|
|
303 begin
|
|
|
304 return Node.Color;
|
|
|
305 end Color;
|
|
|
306
|
|
|
307 ------------------------
|
|
|
308 -- Constant_Reference --
|
|
|
309 ------------------------
|
|
|
310
|
|
|
311 function Constant_Reference
|
|
|
312 (Container : aliased Map;
|
|
|
313 Position : Cursor) return Constant_Reference_Type
|
|
|
314 is
|
|
|
315 begin
|
|
|
316 if Checks and then Position.Container = null then
|
|
|
317 raise Constraint_Error with
|
|
|
318 "Position cursor has no element";
|
|
|
319 end if;
|
|
|
320
|
|
|
321 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
322 then
|
|
|
323 raise Program_Error with
|
|
|
324 "Position cursor designates wrong map";
|
|
|
325 end if;
|
|
|
326
|
|
|
327 pragma Assert (Vet (Container.Tree, Position.Node),
|
|
|
328 "Position cursor in Constant_Reference is bad");
|
|
|
329
|
|
|
330 declare
|
|
|
331 T : Tree_Type renames Position.Container.all.Tree;
|
|
|
332 TC : constant Tamper_Counts_Access :=
|
|
|
333 T.TC'Unrestricted_Access;
|
|
|
334 begin
|
|
|
335 return R : constant Constant_Reference_Type :=
|
|
|
336 (Element => Position.Node.Element'Access,
|
|
|
337 Control => (Controlled with TC))
|
|
|
338 do
|
|
|
339 Lock (TC.all);
|
|
|
340 end return;
|
|
|
341 end;
|
|
|
342 end Constant_Reference;
|
|
|
343
|
|
|
344 function Constant_Reference
|
|
|
345 (Container : aliased Map;
|
|
|
346 Key : Key_Type) return Constant_Reference_Type
|
|
|
347 is
|
|
|
348 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
349
|
|
|
350 begin
|
|
|
351 if Checks and then Node = null then
|
|
|
352 raise Constraint_Error with "key not in map";
|
|
|
353 end if;
|
|
|
354
|
|
|
355 declare
|
|
|
356 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
|
|
|
357 TC : constant Tamper_Counts_Access :=
|
|
|
358 T.TC'Unrestricted_Access;
|
|
|
359 begin
|
|
|
360 return R : constant Constant_Reference_Type :=
|
|
|
361 (Element => Node.Element'Access,
|
|
|
362 Control => (Controlled with TC))
|
|
|
363 do
|
|
|
364 Lock (TC.all);
|
|
|
365 end return;
|
|
|
366 end;
|
|
|
367 end Constant_Reference;
|
|
|
368
|
|
|
369 --------------
|
|
|
370 -- Contains --
|
|
|
371 --------------
|
|
|
372
|
|
|
373 function Contains (Container : Map; Key : Key_Type) return Boolean is
|
|
|
374 begin
|
|
|
375 return Find (Container, Key) /= No_Element;
|
|
|
376 end Contains;
|
|
|
377
|
|
|
378 ----------
|
|
|
379 -- Copy --
|
|
|
380 ----------
|
|
|
381
|
|
|
382 function Copy (Source : Map) return Map is
|
|
|
383 begin
|
|
|
384 return Target : Map do
|
|
|
385 Target.Assign (Source);
|
|
|
386 end return;
|
|
|
387 end Copy;
|
|
|
388
|
|
|
389 ---------------
|
|
|
390 -- Copy_Node --
|
|
|
391 ---------------
|
|
|
392
|
|
|
393 function Copy_Node (Source : Node_Access) return Node_Access is
|
|
|
394 Target : constant Node_Access :=
|
|
|
395 new Node_Type'(Color => Source.Color,
|
|
|
396 Key => Source.Key,
|
|
|
397 Element => Source.Element,
|
|
|
398 Parent => null,
|
|
|
399 Left => null,
|
|
|
400 Right => null);
|
|
|
401 begin
|
|
|
402 return Target;
|
|
|
403 end Copy_Node;
|
|
|
404
|
|
|
405 ------------
|
|
|
406 -- Delete --
|
|
|
407 ------------
|
|
|
408
|
|
|
409 procedure Delete (Container : in out Map; Position : in out Cursor) is
|
|
|
410 Tree : Tree_Type renames Container.Tree;
|
|
|
411
|
|
|
412 begin
|
|
|
413 if Checks and then Position.Node = null then
|
|
|
414 raise Constraint_Error with
|
|
|
415 "Position cursor of Delete equals No_Element";
|
|
|
416 end if;
|
|
|
417
|
|
|
418 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
419 then
|
|
|
420 raise Program_Error with
|
|
|
421 "Position cursor of Delete designates wrong map";
|
|
|
422 end if;
|
|
|
423
|
|
|
424 pragma Assert (Vet (Tree, Position.Node),
|
|
|
425 "Position cursor of Delete is bad");
|
|
|
426
|
|
|
427 Tree_Operations.Delete_Node_Sans_Free (Tree, Position.Node);
|
|
|
428 Free (Position.Node);
|
|
|
429
|
|
|
430 Position.Container := null;
|
|
|
431 end Delete;
|
|
|
432
|
|
|
433 procedure Delete (Container : in out Map; Key : Key_Type) is
|
|
|
434 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
435
|
|
|
436 begin
|
|
|
437 if Checks and then X = null then
|
|
|
438 raise Constraint_Error with "key not in map";
|
|
|
439 end if;
|
|
|
440
|
|
|
441 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
|
|
|
442 Free (X);
|
|
|
443 end Delete;
|
|
|
444
|
|
|
445 ------------------
|
|
|
446 -- Delete_First --
|
|
|
447 ------------------
|
|
|
448
|
|
|
449 procedure Delete_First (Container : in out Map) is
|
|
|
450 X : Node_Access := Container.Tree.First;
|
|
|
451
|
|
|
452 begin
|
|
|
453 if X /= null then
|
|
|
454 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
|
|
|
455 Free (X);
|
|
|
456 end if;
|
|
|
457 end Delete_First;
|
|
|
458
|
|
|
459 -----------------
|
|
|
460 -- Delete_Last --
|
|
|
461 -----------------
|
|
|
462
|
|
|
463 procedure Delete_Last (Container : in out Map) is
|
|
|
464 X : Node_Access := Container.Tree.Last;
|
|
|
465
|
|
|
466 begin
|
|
|
467 if X /= null then
|
|
|
468 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
|
|
|
469 Free (X);
|
|
|
470 end if;
|
|
|
471 end Delete_Last;
|
|
|
472
|
|
|
473 -------------
|
|
|
474 -- Element --
|
|
|
475 -------------
|
|
|
476
|
|
|
477 function Element (Position : Cursor) return Element_Type is
|
|
|
478 begin
|
|
|
479 if Checks and then Position.Node = null then
|
|
|
480 raise Constraint_Error with
|
|
|
481 "Position cursor of function Element equals No_Element";
|
|
|
482 end if;
|
|
|
483
|
|
131
|
484 if Checks
|
|
|
485 and then (Left (Position.Node) = Position.Node
|
|
|
486 or else
|
|
|
487 Right (Position.Node) = Position.Node)
|
|
|
488 then
|
|
|
489 raise Program_Error with "dangling cursor";
|
|
|
490 end if;
|
|
|
491
|
|
111
|
492 pragma Assert (Vet (Position.Container.Tree, Position.Node),
|
|
|
493 "Position cursor of function Element is bad");
|
|
|
494
|
|
|
495 return Position.Node.Element;
|
|
|
496 end Element;
|
|
|
497
|
|
|
498 function Element (Container : Map; Key : Key_Type) return Element_Type is
|
|
|
499 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
500
|
|
|
501 begin
|
|
|
502 if Checks and then Node = null then
|
|
|
503 raise Constraint_Error with "key not in map";
|
|
|
504 end if;
|
|
|
505
|
|
|
506 return Node.Element;
|
|
|
507 end Element;
|
|
|
508
|
|
|
509 ---------------------
|
|
|
510 -- Equivalent_Keys --
|
|
|
511 ---------------------
|
|
|
512
|
|
|
513 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
|
|
|
514 begin
|
|
|
515 if Left < Right
|
|
|
516 or else Right < Left
|
|
|
517 then
|
|
|
518 return False;
|
|
|
519 else
|
|
|
520 return True;
|
|
|
521 end if;
|
|
|
522 end Equivalent_Keys;
|
|
|
523
|
|
|
524 -------------
|
|
|
525 -- Exclude --
|
|
|
526 -------------
|
|
|
527
|
|
|
528 procedure Exclude (Container : in out Map; Key : Key_Type) is
|
|
|
529 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
530
|
|
|
531 begin
|
|
|
532 if X /= null then
|
|
|
533 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
|
|
|
534 Free (X);
|
|
|
535 end if;
|
|
|
536 end Exclude;
|
|
|
537
|
|
|
538 --------------
|
|
|
539 -- Finalize --
|
|
|
540 --------------
|
|
|
541
|
|
|
542 procedure Finalize (Object : in out Iterator) is
|
|
|
543 begin
|
|
|
544 if Object.Container /= null then
|
|
|
545 Unbusy (Object.Container.Tree.TC);
|
|
|
546 end if;
|
|
|
547 end Finalize;
|
|
|
548
|
|
|
549 ----------
|
|
|
550 -- Find --
|
|
|
551 ----------
|
|
|
552
|
|
|
553 function Find (Container : Map; Key : Key_Type) return Cursor is
|
|
|
554 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
555 begin
|
|
|
556 return (if Node = null then No_Element
|
|
|
557 else Cursor'(Container'Unrestricted_Access, Node));
|
|
|
558 end Find;
|
|
|
559
|
|
|
560 -----------
|
|
|
561 -- First --
|
|
|
562 -----------
|
|
|
563
|
|
|
564 function First (Container : Map) return Cursor is
|
|
|
565 T : Tree_Type renames Container.Tree;
|
|
|
566 begin
|
|
|
567 if T.First = null then
|
|
|
568 return No_Element;
|
|
|
569 else
|
|
|
570 return Cursor'(Container'Unrestricted_Access, T.First);
|
|
|
571 end if;
|
|
|
572 end First;
|
|
|
573
|
|
|
574 function First (Object : Iterator) return Cursor is
|
|
|
575 begin
|
|
|
576 -- The value of the iterator object's Node component influences the
|
|
|
577 -- behavior of the First (and Last) selector function.
|
|
|
578
|
|
|
579 -- When the Node component is null, this means the iterator object was
|
|
|
580 -- constructed without a start expression, in which case the (forward)
|
|
|
581 -- iteration starts from the (logical) beginning of the entire sequence
|
|
|
582 -- of items (corresponding to Container.First, for a forward iterator).
|
|
|
583
|
|
|
584 -- Otherwise, this is iteration over a partial sequence of items. When
|
|
|
585 -- the Node component is non-null, the iterator object was constructed
|
|
|
586 -- with a start expression, that specifies the position from which the
|
|
|
587 -- (forward) partial iteration begins.
|
|
|
588
|
|
|
589 if Object.Node = null then
|
|
|
590 return Object.Container.First;
|
|
|
591 else
|
|
|
592 return Cursor'(Object.Container, Object.Node);
|
|
|
593 end if;
|
|
|
594 end First;
|
|
|
595
|
|
|
596 -------------------
|
|
|
597 -- First_Element --
|
|
|
598 -------------------
|
|
|
599
|
|
|
600 function First_Element (Container : Map) return Element_Type is
|
|
|
601 T : Tree_Type renames Container.Tree;
|
|
|
602 begin
|
|
|
603 if Checks and then T.First = null then
|
|
|
604 raise Constraint_Error with "map is empty";
|
|
|
605 end if;
|
|
|
606
|
|
|
607 return T.First.Element;
|
|
|
608 end First_Element;
|
|
|
609
|
|
|
610 ---------------
|
|
|
611 -- First_Key --
|
|
|
612 ---------------
|
|
|
613
|
|
|
614 function First_Key (Container : Map) return Key_Type is
|
|
|
615 T : Tree_Type renames Container.Tree;
|
|
|
616 begin
|
|
|
617 if Checks and then T.First = null then
|
|
|
618 raise Constraint_Error with "map is empty";
|
|
|
619 end if;
|
|
|
620
|
|
|
621 return T.First.Key;
|
|
|
622 end First_Key;
|
|
|
623
|
|
|
624 -----------
|
|
|
625 -- Floor --
|
|
|
626 -----------
|
|
|
627
|
|
|
628 function Floor (Container : Map; Key : Key_Type) return Cursor is
|
|
|
629 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
|
|
|
630 begin
|
|
|
631 if Node = null then
|
|
|
632 return No_Element;
|
|
|
633 else
|
|
|
634 return Cursor'(Container'Unrestricted_Access, Node);
|
|
|
635 end if;
|
|
|
636 end Floor;
|
|
|
637
|
|
|
638 ----------
|
|
|
639 -- Free --
|
|
|
640 ----------
|
|
|
641
|
|
|
642 procedure Free (X : in out Node_Access) is
|
|
|
643 procedure Deallocate is
|
|
|
644 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
|
|
|
645
|
|
|
646 begin
|
|
|
647 if X = null then
|
|
|
648 return;
|
|
|
649 end if;
|
|
|
650
|
|
|
651 X.Parent := X;
|
|
|
652 X.Left := X;
|
|
|
653 X.Right := X;
|
|
|
654
|
|
|
655 Deallocate (X);
|
|
|
656 end Free;
|
|
|
657
|
|
|
658 ------------------------
|
|
|
659 -- Get_Element_Access --
|
|
|
660 ------------------------
|
|
|
661
|
|
|
662 function Get_Element_Access
|
|
|
663 (Position : Cursor) return not null Element_Access is
|
|
|
664 begin
|
|
|
665 return Position.Node.Element'Access;
|
|
|
666 end Get_Element_Access;
|
|
|
667
|
|
|
668 -----------------
|
|
|
669 -- Has_Element --
|
|
|
670 -----------------
|
|
|
671
|
|
|
672 function Has_Element (Position : Cursor) return Boolean is
|
|
|
673 begin
|
|
|
674 return Position /= No_Element;
|
|
|
675 end Has_Element;
|
|
|
676
|
|
|
677 -------------
|
|
|
678 -- Include --
|
|
|
679 -------------
|
|
|
680
|
|
|
681 procedure Include
|
|
|
682 (Container : in out Map;
|
|
|
683 Key : Key_Type;
|
|
|
684 New_Item : Element_Type)
|
|
|
685 is
|
|
|
686 Position : Cursor;
|
|
|
687 Inserted : Boolean;
|
|
|
688
|
|
|
689 begin
|
|
|
690 Insert (Container, Key, New_Item, Position, Inserted);
|
|
|
691
|
|
|
692 if not Inserted then
|
|
|
693 TE_Check (Container.Tree.TC);
|
|
|
694
|
|
|
695 Position.Node.Key := Key;
|
|
|
696 Position.Node.Element := New_Item;
|
|
|
697 end if;
|
|
|
698 end Include;
|
|
|
699
|
|
|
700 ------------
|
|
|
701 -- Insert --
|
|
|
702 ------------
|
|
|
703
|
|
|
704 procedure Insert
|
|
|
705 (Container : in out Map;
|
|
|
706 Key : Key_Type;
|
|
|
707 New_Item : Element_Type;
|
|
|
708 Position : out Cursor;
|
|
|
709 Inserted : out Boolean)
|
|
|
710 is
|
|
|
711 function New_Node return Node_Access;
|
|
|
712 pragma Inline (New_Node);
|
|
|
713
|
|
|
714 procedure Insert_Post is
|
|
|
715 new Key_Ops.Generic_Insert_Post (New_Node);
|
|
|
716
|
|
|
717 procedure Insert_Sans_Hint is
|
|
|
718 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
|
|
|
719
|
|
|
720 --------------
|
|
|
721 -- New_Node --
|
|
|
722 --------------
|
|
|
723
|
|
|
724 function New_Node return Node_Access is
|
|
|
725 begin
|
|
|
726 return new Node_Type'(Key => Key,
|
|
|
727 Element => New_Item,
|
|
|
728 Color => Red_Black_Trees.Red,
|
|
|
729 Parent => null,
|
|
|
730 Left => null,
|
|
|
731 Right => null);
|
|
|
732 end New_Node;
|
|
|
733
|
|
|
734 -- Start of processing for Insert
|
|
|
735
|
|
|
736 begin
|
|
|
737 Insert_Sans_Hint
|
|
|
738 (Container.Tree,
|
|
|
739 Key,
|
|
|
740 Position.Node,
|
|
|
741 Inserted);
|
|
|
742
|
|
|
743 Position.Container := Container'Unrestricted_Access;
|
|
|
744 end Insert;
|
|
|
745
|
|
|
746 procedure Insert
|
|
|
747 (Container : in out Map;
|
|
|
748 Key : Key_Type;
|
|
|
749 New_Item : Element_Type)
|
|
|
750 is
|
|
|
751 Position : Cursor;
|
|
|
752 pragma Unreferenced (Position);
|
|
|
753
|
|
|
754 Inserted : Boolean;
|
|
|
755
|
|
|
756 begin
|
|
|
757 Insert (Container, Key, New_Item, Position, Inserted);
|
|
|
758
|
|
|
759 if Checks and then not Inserted then
|
|
|
760 raise Constraint_Error with "key already in map";
|
|
|
761 end if;
|
|
|
762 end Insert;
|
|
|
763
|
|
|
764 procedure Insert
|
|
|
765 (Container : in out Map;
|
|
|
766 Key : Key_Type;
|
|
|
767 Position : out Cursor;
|
|
|
768 Inserted : out Boolean)
|
|
|
769 is
|
|
|
770 function New_Node return Node_Access;
|
|
|
771 pragma Inline (New_Node);
|
|
|
772
|
|
|
773 procedure Insert_Post is
|
|
|
774 new Key_Ops.Generic_Insert_Post (New_Node);
|
|
|
775
|
|
|
776 procedure Insert_Sans_Hint is
|
|
|
777 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
|
|
|
778
|
|
|
779 --------------
|
|
|
780 -- New_Node --
|
|
|
781 --------------
|
|
|
782
|
|
|
783 function New_Node return Node_Access is
|
|
|
784 begin
|
|
|
785 return new Node_Type'(Key => Key,
|
|
|
786 Element => <>,
|
|
|
787 Color => Red_Black_Trees.Red,
|
|
|
788 Parent => null,
|
|
|
789 Left => null,
|
|
|
790 Right => null);
|
|
|
791 end New_Node;
|
|
|
792
|
|
|
793 -- Start of processing for Insert
|
|
|
794
|
|
|
795 begin
|
|
|
796 Insert_Sans_Hint
|
|
|
797 (Container.Tree,
|
|
|
798 Key,
|
|
|
799 Position.Node,
|
|
|
800 Inserted);
|
|
|
801
|
|
|
802 Position.Container := Container'Unrestricted_Access;
|
|
|
803 end Insert;
|
|
|
804
|
|
|
805 --------------
|
|
|
806 -- Is_Empty --
|
|
|
807 --------------
|
|
|
808
|
|
|
809 function Is_Empty (Container : Map) return Boolean is
|
|
|
810 begin
|
|
|
811 return Container.Tree.Length = 0;
|
|
|
812 end Is_Empty;
|
|
|
813
|
|
|
814 ------------------------
|
|
|
815 -- Is_Equal_Node_Node --
|
|
|
816 ------------------------
|
|
|
817
|
|
|
818 function Is_Equal_Node_Node
|
|
|
819 (L, R : Node_Access) return Boolean
|
|
|
820 is
|
|
|
821 begin
|
|
|
822 if L.Key < R.Key then
|
|
|
823 return False;
|
|
|
824 elsif R.Key < L.Key then
|
|
|
825 return False;
|
|
|
826 else
|
|
|
827 return L.Element = R.Element;
|
|
|
828 end if;
|
|
|
829 end Is_Equal_Node_Node;
|
|
|
830
|
|
|
831 -------------------------
|
|
|
832 -- Is_Greater_Key_Node --
|
|
|
833 -------------------------
|
|
|
834
|
|
|
835 function Is_Greater_Key_Node
|
|
|
836 (Left : Key_Type;
|
|
|
837 Right : Node_Access) return Boolean
|
|
|
838 is
|
|
|
839 begin
|
|
|
840 -- Left > Right same as Right < Left
|
|
|
841
|
|
|
842 return Right.Key < Left;
|
|
|
843 end Is_Greater_Key_Node;
|
|
|
844
|
|
|
845 ----------------------
|
|
|
846 -- Is_Less_Key_Node --
|
|
|
847 ----------------------
|
|
|
848
|
|
|
849 function Is_Less_Key_Node
|
|
|
850 (Left : Key_Type;
|
|
|
851 Right : Node_Access) return Boolean
|
|
|
852 is
|
|
|
853 begin
|
|
|
854 return Left < Right.Key;
|
|
|
855 end Is_Less_Key_Node;
|
|
|
856
|
|
|
857 -------------
|
|
|
858 -- Iterate --
|
|
|
859 -------------
|
|
|
860
|
|
|
861 procedure Iterate
|
|
|
862 (Container : Map;
|
|
|
863 Process : not null access procedure (Position : Cursor))
|
|
|
864 is
|
|
|
865 procedure Process_Node (Node : Node_Access);
|
|
|
866 pragma Inline (Process_Node);
|
|
|
867
|
|
|
868 procedure Local_Iterate is
|
|
|
869 new Tree_Operations.Generic_Iteration (Process_Node);
|
|
|
870
|
|
|
871 ------------------
|
|
|
872 -- Process_Node --
|
|
|
873 ------------------
|
|
|
874
|
|
|
875 procedure Process_Node (Node : Node_Access) is
|
|
|
876 begin
|
|
|
877 Process (Cursor'(Container'Unrestricted_Access, Node));
|
|
|
878 end Process_Node;
|
|
|
879
|
|
|
880 Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
|
|
|
881
|
|
|
882 -- Start of processing for Iterate
|
|
|
883
|
|
|
884 begin
|
|
|
885 Local_Iterate (Container.Tree);
|
|
|
886 end Iterate;
|
|
|
887
|
|
|
888 function Iterate
|
|
|
889 (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
|
|
|
890 is
|
|
|
891 begin
|
|
|
892 -- The value of the Node component influences the behavior of the First
|
|
|
893 -- and Last selector functions of the iterator object. When the Node
|
|
|
894 -- component is null (as is the case here), this means the iterator
|
|
|
895 -- object was constructed without a start expression. This is a
|
|
|
896 -- complete iterator, meaning that the iteration starts from the
|
|
|
897 -- (logical) beginning of the sequence of items.
|
|
|
898
|
|
|
899 -- Note: For a forward iterator, Container.First is the beginning, and
|
|
|
900 -- for a reverse iterator, Container.Last is the beginning.
|
|
|
901
|
|
|
902 return It : constant Iterator :=
|
|
|
903 (Limited_Controlled with
|
|
|
904 Container => Container'Unrestricted_Access,
|
|
|
905 Node => null)
|
|
|
906 do
|
|
|
907 Busy (Container.Tree.TC'Unrestricted_Access.all);
|
|
|
908 end return;
|
|
|
909 end Iterate;
|
|
|
910
|
|
|
911 function Iterate (Container : Map; Start : Cursor)
|
|
|
912 return Map_Iterator_Interfaces.Reversible_Iterator'Class
|
|
|
913 is
|
|
|
914 begin
|
|
|
915 -- It was formerly the case that when Start = No_Element, the partial
|
|
|
916 -- iterator was defined to behave the same as for a complete iterator,
|
|
|
917 -- and iterate over the entire sequence of items. However, those
|
|
|
918 -- semantics were unintuitive and arguably error-prone (it is too easy
|
|
|
919 -- to accidentally create an endless loop), and so they were changed,
|
|
|
920 -- per the ARG meeting in Denver on 2011/11. However, there was no
|
|
|
921 -- consensus about what positive meaning this corner case should have,
|
|
|
922 -- and so it was decided to simply raise an exception. This does imply,
|
|
|
923 -- however, that it is not possible to use a partial iterator to specify
|
|
|
924 -- an empty sequence of items.
|
|
|
925
|
|
|
926 if Checks and then Start = No_Element then
|
|
|
927 raise Constraint_Error with
|
|
|
928 "Start position for iterator equals No_Element";
|
|
|
929 end if;
|
|
|
930
|
|
|
931 if Checks and then Start.Container /= Container'Unrestricted_Access then
|
|
|
932 raise Program_Error with
|
|
|
933 "Start cursor of Iterate designates wrong map";
|
|
|
934 end if;
|
|
|
935
|
|
|
936 pragma Assert (Vet (Container.Tree, Start.Node),
|
|
|
937 "Start cursor of Iterate is bad");
|
|
|
938
|
|
|
939 -- The value of the Node component influences the behavior of the First
|
|
|
940 -- and Last selector functions of the iterator object. When the Node
|
|
|
941 -- component is non-null (as is the case here), it means that this
|
|
|
942 -- is a partial iteration, over a subset of the complete sequence of
|
|
|
943 -- items. The iterator object was constructed with a start expression,
|
|
|
944 -- indicating the position from which the iteration begins. Note that
|
|
|
945 -- the start position has the same value irrespective of whether this
|
|
|
946 -- is a forward or reverse iteration.
|
|
|
947
|
|
|
948 return It : constant Iterator :=
|
|
|
949 (Limited_Controlled with
|
|
|
950 Container => Container'Unrestricted_Access,
|
|
|
951 Node => Start.Node)
|
|
|
952 do
|
|
|
953 Busy (Container.Tree.TC'Unrestricted_Access.all);
|
|
|
954 end return;
|
|
|
955 end Iterate;
|
|
|
956
|
|
|
957 ---------
|
|
|
958 -- Key --
|
|
|
959 ---------
|
|
|
960
|
|
|
961 function Key (Position : Cursor) return Key_Type is
|
|
|
962 begin
|
|
|
963 if Checks and then Position.Node = null then
|
|
|
964 raise Constraint_Error with
|
|
|
965 "Position cursor of function Key equals No_Element";
|
|
|
966 end if;
|
|
|
967
|
|
|
968 pragma Assert (Vet (Position.Container.Tree, Position.Node),
|
|
|
969 "Position cursor of function Key is bad");
|
|
|
970
|
|
|
971 return Position.Node.Key;
|
|
|
972 end Key;
|
|
|
973
|
|
|
974 ----------
|
|
|
975 -- Last --
|
|
|
976 ----------
|
|
|
977
|
|
|
978 function Last (Container : Map) return Cursor is
|
|
|
979 T : Tree_Type renames Container.Tree;
|
|
|
980 begin
|
|
|
981 if T.Last = null then
|
|
|
982 return No_Element;
|
|
|
983 else
|
|
|
984 return Cursor'(Container'Unrestricted_Access, T.Last);
|
|
|
985 end if;
|
|
|
986 end Last;
|
|
|
987
|
|
|
988 function Last (Object : Iterator) return Cursor is
|
|
|
989 begin
|
|
|
990 -- The value of the iterator object's Node component influences the
|
|
|
991 -- behavior of the Last (and First) selector function.
|
|
|
992
|
|
|
993 -- When the Node component is null, this means the iterator object was
|
|
|
994 -- constructed without a start expression, in which case the (reverse)
|
|
|
995 -- iteration starts from the (logical) beginning of the entire sequence
|
|
|
996 -- (corresponding to Container.Last, for a reverse iterator).
|
|
|
997
|
|
|
998 -- Otherwise, this is iteration over a partial sequence of items. When
|
|
|
999 -- the Node component is non-null, the iterator object was constructed
|
|
|
1000 -- with a start expression, that specifies the position from which the
|
|
|
1001 -- (reverse) partial iteration begins.
|
|
|
1002
|
|
|
1003 if Object.Node = null then
|
|
|
1004 return Object.Container.Last;
|
|
|
1005 else
|
|
|
1006 return Cursor'(Object.Container, Object.Node);
|
|
|
1007 end if;
|
|
|
1008 end Last;
|
|
|
1009
|
|
|
1010 ------------------
|
|
|
1011 -- Last_Element --
|
|
|
1012 ------------------
|
|
|
1013
|
|
|
1014 function Last_Element (Container : Map) return Element_Type is
|
|
|
1015 T : Tree_Type renames Container.Tree;
|
|
|
1016 begin
|
|
|
1017 if Checks and then T.Last = null then
|
|
|
1018 raise Constraint_Error with "map is empty";
|
|
|
1019 end if;
|
|
|
1020
|
|
|
1021 return T.Last.Element;
|
|
|
1022 end Last_Element;
|
|
|
1023
|
|
|
1024 --------------
|
|
|
1025 -- Last_Key --
|
|
|
1026 --------------
|
|
|
1027
|
|
|
1028 function Last_Key (Container : Map) return Key_Type is
|
|
|
1029 T : Tree_Type renames Container.Tree;
|
|
|
1030 begin
|
|
|
1031 if Checks and then T.Last = null then
|
|
|
1032 raise Constraint_Error with "map is empty";
|
|
|
1033 end if;
|
|
|
1034
|
|
|
1035 return T.Last.Key;
|
|
|
1036 end Last_Key;
|
|
|
1037
|
|
|
1038 ----------
|
|
|
1039 -- Left --
|
|
|
1040 ----------
|
|
|
1041
|
|
|
1042 function Left (Node : Node_Access) return Node_Access is
|
|
|
1043 begin
|
|
|
1044 return Node.Left;
|
|
|
1045 end Left;
|
|
|
1046
|
|
|
1047 ------------
|
|
|
1048 -- Length --
|
|
|
1049 ------------
|
|
|
1050
|
|
|
1051 function Length (Container : Map) return Count_Type is
|
|
|
1052 begin
|
|
|
1053 return Container.Tree.Length;
|
|
|
1054 end Length;
|
|
|
1055
|
|
|
1056 ----------
|
|
|
1057 -- Move --
|
|
|
1058 ----------
|
|
|
1059
|
|
|
1060 procedure Move is
|
|
|
1061 new Tree_Operations.Generic_Move (Clear);
|
|
|
1062
|
|
|
1063 procedure Move (Target : in out Map; Source : in out Map) is
|
|
|
1064 begin
|
|
|
1065 Move (Target => Target.Tree, Source => Source.Tree);
|
|
|
1066 end Move;
|
|
|
1067
|
|
|
1068 ----------
|
|
|
1069 -- Next --
|
|
|
1070 ----------
|
|
|
1071
|
|
|
1072 procedure Next (Position : in out Cursor) is
|
|
|
1073 begin
|
|
|
1074 Position := Next (Position);
|
|
|
1075 end Next;
|
|
|
1076
|
|
|
1077 function Next (Position : Cursor) return Cursor is
|
|
|
1078 begin
|
|
|
1079 if Position = No_Element then
|
|
|
1080 return No_Element;
|
|
|
1081 end if;
|
|
|
1082
|
|
|
1083 pragma Assert (Vet (Position.Container.Tree, Position.Node),
|
|
|
1084 "Position cursor of Next is bad");
|
|
|
1085
|
|
|
1086 declare
|
|
|
1087 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
|
|
|
1088
|
|
|
1089 begin
|
|
|
1090 if Node = null then
|
|
|
1091 return No_Element;
|
|
|
1092 end if;
|
|
|
1093
|
|
|
1094 return Cursor'(Position.Container, Node);
|
|
|
1095 end;
|
|
|
1096 end Next;
|
|
|
1097
|
|
|
1098 function Next
|
|
|
1099 (Object : Iterator;
|
|
|
1100 Position : Cursor) return Cursor
|
|
|
1101 is
|
|
|
1102 begin
|
|
|
1103 if Position.Container = null then
|
|
|
1104 return No_Element;
|
|
|
1105 end if;
|
|
|
1106
|
|
|
1107 if Checks and then Position.Container /= Object.Container then
|
|
|
1108 raise Program_Error with
|
|
|
1109 "Position cursor of Next designates wrong map";
|
|
|
1110 end if;
|
|
|
1111
|
|
|
1112 return Next (Position);
|
|
|
1113 end Next;
|
|
|
1114
|
|
|
1115 ------------
|
|
|
1116 -- Parent --
|
|
|
1117 ------------
|
|
|
1118
|
|
|
1119 function Parent (Node : Node_Access) return Node_Access is
|
|
|
1120 begin
|
|
|
1121 return Node.Parent;
|
|
|
1122 end Parent;
|
|
|
1123
|
|
|
1124 --------------
|
|
|
1125 -- Previous --
|
|
|
1126 --------------
|
|
|
1127
|
|
|
1128 procedure Previous (Position : in out Cursor) is
|
|
|
1129 begin
|
|
|
1130 Position := Previous (Position);
|
|
|
1131 end Previous;
|
|
|
1132
|
|
|
1133 function Previous (Position : Cursor) return Cursor is
|
|
|
1134 begin
|
|
|
1135 if Position = No_Element then
|
|
|
1136 return No_Element;
|
|
|
1137 end if;
|
|
|
1138
|
|
|
1139 pragma Assert (Vet (Position.Container.Tree, Position.Node),
|
|
|
1140 "Position cursor of Previous is bad");
|
|
|
1141
|
|
|
1142 declare
|
|
|
1143 Node : constant Node_Access :=
|
|
|
1144 Tree_Operations.Previous (Position.Node);
|
|
|
1145
|
|
|
1146 begin
|
|
|
1147 if Node = null then
|
|
|
1148 return No_Element;
|
|
|
1149 end if;
|
|
|
1150
|
|
|
1151 return Cursor'(Position.Container, Node);
|
|
|
1152 end;
|
|
|
1153 end Previous;
|
|
|
1154
|
|
|
1155 function Previous
|
|
|
1156 (Object : Iterator;
|
|
|
1157 Position : Cursor) return Cursor
|
|
|
1158 is
|
|
|
1159 begin
|
|
|
1160 if Position.Container = null then
|
|
|
1161 return No_Element;
|
|
|
1162 end if;
|
|
|
1163
|
|
|
1164 if Checks and then Position.Container /= Object.Container then
|
|
|
1165 raise Program_Error with
|
|
|
1166 "Position cursor of Previous designates wrong map";
|
|
|
1167 end if;
|
|
|
1168
|
|
|
1169 return Previous (Position);
|
|
|
1170 end Previous;
|
|
|
1171
|
|
|
1172 ----------------------
|
|
|
1173 -- Pseudo_Reference --
|
|
|
1174 ----------------------
|
|
|
1175
|
|
|
1176 function Pseudo_Reference
|
|
|
1177 (Container : aliased Map'Class) return Reference_Control_Type
|
|
|
1178 is
|
|
|
1179 TC : constant Tamper_Counts_Access :=
|
|
|
1180 Container.Tree.TC'Unrestricted_Access;
|
|
|
1181 begin
|
|
|
1182 return R : constant Reference_Control_Type := (Controlled with TC) do
|
|
|
1183 Lock (TC.all);
|
|
|
1184 end return;
|
|
|
1185 end Pseudo_Reference;
|
|
|
1186
|
|
|
1187 -------------------
|
|
|
1188 -- Query_Element --
|
|
|
1189 -------------------
|
|
|
1190
|
|
|
1191 procedure Query_Element
|
|
|
1192 (Position : Cursor;
|
|
|
1193 Process : not null access procedure (Key : Key_Type;
|
|
|
1194 Element : Element_Type))
|
|
|
1195 is
|
|
|
1196 begin
|
|
|
1197 if Checks and then Position.Node = null then
|
|
|
1198 raise Constraint_Error with
|
|
|
1199 "Position cursor of Query_Element equals No_Element";
|
|
|
1200 end if;
|
|
|
1201
|
|
|
1202 pragma Assert (Vet (Position.Container.Tree, Position.Node),
|
|
|
1203 "Position cursor of Query_Element is bad");
|
|
|
1204
|
|
|
1205 declare
|
|
|
1206 T : Tree_Type renames Position.Container.Tree;
|
|
|
1207 Lock : With_Lock (T.TC'Unrestricted_Access);
|
|
|
1208 K : Key_Type renames Position.Node.Key;
|
|
|
1209 E : Element_Type renames Position.Node.Element;
|
|
|
1210 begin
|
|
|
1211 Process (K, E);
|
|
|
1212 end;
|
|
|
1213 end Query_Element;
|
|
|
1214
|
|
|
1215 ----------
|
|
|
1216 -- Read --
|
|
|
1217 ----------
|
|
|
1218
|
|
|
1219 procedure Read
|
|
|
1220 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1221 Container : out Map)
|
|
|
1222 is
|
|
|
1223 function Read_Node
|
|
|
1224 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
|
|
|
1225 pragma Inline (Read_Node);
|
|
|
1226
|
|
|
1227 procedure Read is
|
|
|
1228 new Tree_Operations.Generic_Read (Clear, Read_Node);
|
|
|
1229
|
|
|
1230 ---------------
|
|
|
1231 -- Read_Node --
|
|
|
1232 ---------------
|
|
|
1233
|
|
|
1234 function Read_Node
|
|
|
1235 (Stream : not null access Root_Stream_Type'Class) return Node_Access
|
|
|
1236 is
|
|
|
1237 Node : Node_Access := new Node_Type;
|
|
|
1238 begin
|
|
|
1239 Key_Type'Read (Stream, Node.Key);
|
|
|
1240 Element_Type'Read (Stream, Node.Element);
|
|
|
1241 return Node;
|
|
|
1242 exception
|
|
|
1243 when others =>
|
|
|
1244 Free (Node);
|
|
|
1245 raise;
|
|
|
1246 end Read_Node;
|
|
|
1247
|
|
|
1248 -- Start of processing for Read
|
|
|
1249
|
|
|
1250 begin
|
|
|
1251 Read (Stream, Container.Tree);
|
|
|
1252 end Read;
|
|
|
1253
|
|
|
1254 procedure Read
|
|
|
1255 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1256 Item : out Cursor)
|
|
|
1257 is
|
|
|
1258 begin
|
|
|
1259 raise Program_Error with "attempt to stream map cursor";
|
|
|
1260 end Read;
|
|
|
1261
|
|
|
1262 procedure Read
|
|
|
1263 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1264 Item : out Reference_Type)
|
|
|
1265 is
|
|
|
1266 begin
|
|
|
1267 raise Program_Error with "attempt to stream reference";
|
|
|
1268 end Read;
|
|
|
1269
|
|
|
1270 procedure Read
|
|
|
1271 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1272 Item : out Constant_Reference_Type)
|
|
|
1273 is
|
|
|
1274 begin
|
|
|
1275 raise Program_Error with "attempt to stream reference";
|
|
|
1276 end Read;
|
|
|
1277
|
|
|
1278 ---------------
|
|
|
1279 -- Reference --
|
|
|
1280 ---------------
|
|
|
1281
|
|
|
1282 function Reference
|
|
|
1283 (Container : aliased in out Map;
|
|
|
1284 Position : Cursor) return Reference_Type
|
|
|
1285 is
|
|
|
1286 begin
|
|
|
1287 if Checks and then Position.Container = null then
|
|
|
1288 raise Constraint_Error with
|
|
|
1289 "Position cursor has no element";
|
|
|
1290 end if;
|
|
|
1291
|
|
|
1292 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1293 then
|
|
|
1294 raise Program_Error with
|
|
|
1295 "Position cursor designates wrong map";
|
|
|
1296 end if;
|
|
|
1297
|
|
|
1298 pragma Assert (Vet (Container.Tree, Position.Node),
|
|
|
1299 "Position cursor in function Reference is bad");
|
|
|
1300
|
|
|
1301 declare
|
|
|
1302 T : Tree_Type renames Position.Container.all.Tree;
|
|
|
1303 TC : constant Tamper_Counts_Access :=
|
|
|
1304 T.TC'Unrestricted_Access;
|
|
|
1305 begin
|
|
|
1306 return R : constant Reference_Type :=
|
|
|
1307 (Element => Position.Node.Element'Access,
|
|
|
1308 Control => (Controlled with TC))
|
|
|
1309 do
|
|
|
1310 Lock (TC.all);
|
|
|
1311 end return;
|
|
|
1312 end;
|
|
|
1313 end Reference;
|
|
|
1314
|
|
|
1315 function Reference
|
|
|
1316 (Container : aliased in out Map;
|
|
|
1317 Key : Key_Type) return Reference_Type
|
|
|
1318 is
|
|
|
1319 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
1320
|
|
|
1321 begin
|
|
|
1322 if Checks and then Node = null then
|
|
|
1323 raise Constraint_Error with "key not in map";
|
|
|
1324 end if;
|
|
|
1325
|
|
|
1326 declare
|
|
|
1327 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
|
|
|
1328 TC : constant Tamper_Counts_Access :=
|
|
|
1329 T.TC'Unrestricted_Access;
|
|
|
1330 begin
|
|
|
1331 return R : constant Reference_Type :=
|
|
|
1332 (Element => Node.Element'Access,
|
|
|
1333 Control => (Controlled with TC))
|
|
|
1334 do
|
|
|
1335 Lock (TC.all);
|
|
|
1336 end return;
|
|
|
1337 end;
|
|
|
1338 end Reference;
|
|
|
1339
|
|
|
1340 -------------
|
|
|
1341 -- Replace --
|
|
|
1342 -------------
|
|
|
1343
|
|
|
1344 procedure Replace
|
|
|
1345 (Container : in out Map;
|
|
|
1346 Key : Key_Type;
|
|
|
1347 New_Item : Element_Type)
|
|
|
1348 is
|
|
|
1349 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
1350
|
|
|
1351 begin
|
|
|
1352 if Checks and then Node = null then
|
|
|
1353 raise Constraint_Error with "key not in map";
|
|
|
1354 end if;
|
|
|
1355
|
|
|
1356 TE_Check (Container.Tree.TC);
|
|
|
1357
|
|
|
1358 Node.Key := Key;
|
|
|
1359 Node.Element := New_Item;
|
|
|
1360 end Replace;
|
|
|
1361
|
|
|
1362 ---------------------
|
|
|
1363 -- Replace_Element --
|
|
|
1364 ---------------------
|
|
|
1365
|
|
|
1366 procedure Replace_Element
|
|
|
1367 (Container : in out Map;
|
|
|
1368 Position : Cursor;
|
|
|
1369 New_Item : Element_Type)
|
|
|
1370 is
|
|
|
1371 begin
|
|
|
1372 if Checks and then Position.Node = null then
|
|
|
1373 raise Constraint_Error with
|
|
|
1374 "Position cursor of Replace_Element equals No_Element";
|
|
|
1375 end if;
|
|
|
1376
|
|
|
1377 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1378 then
|
|
|
1379 raise Program_Error with
|
|
|
1380 "Position cursor of Replace_Element designates wrong map";
|
|
|
1381 end if;
|
|
|
1382
|
|
|
1383 TE_Check (Container.Tree.TC);
|
|
|
1384
|
|
|
1385 pragma Assert (Vet (Container.Tree, Position.Node),
|
|
|
1386 "Position cursor of Replace_Element is bad");
|
|
|
1387
|
|
|
1388 Position.Node.Element := New_Item;
|
|
|
1389 end Replace_Element;
|
|
|
1390
|
|
|
1391 ---------------------
|
|
|
1392 -- Reverse_Iterate --
|
|
|
1393 ---------------------
|
|
|
1394
|
|
|
1395 procedure Reverse_Iterate
|
|
|
1396 (Container : Map;
|
|
|
1397 Process : not null access procedure (Position : Cursor))
|
|
|
1398 is
|
|
|
1399 procedure Process_Node (Node : Node_Access);
|
|
|
1400 pragma Inline (Process_Node);
|
|
|
1401
|
|
|
1402 procedure Local_Reverse_Iterate is
|
|
|
1403 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
|
|
|
1404
|
|
|
1405 ------------------
|
|
|
1406 -- Process_Node --
|
|
|
1407 ------------------
|
|
|
1408
|
|
|
1409 procedure Process_Node (Node : Node_Access) is
|
|
|
1410 begin
|
|
|
1411 Process (Cursor'(Container'Unrestricted_Access, Node));
|
|
|
1412 end Process_Node;
|
|
|
1413
|
|
|
1414 Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
|
|
|
1415
|
|
|
1416 -- Start of processing for Reverse_Iterate
|
|
|
1417
|
|
|
1418 begin
|
|
|
1419 Local_Reverse_Iterate (Container.Tree);
|
|
|
1420 end Reverse_Iterate;
|
|
|
1421
|
|
|
1422 -----------
|
|
|
1423 -- Right --
|
|
|
1424 -----------
|
|
|
1425
|
|
|
1426 function Right (Node : Node_Access) return Node_Access is
|
|
|
1427 begin
|
|
|
1428 return Node.Right;
|
|
|
1429 end Right;
|
|
|
1430
|
|
|
1431 ---------------
|
|
|
1432 -- Set_Color --
|
|
|
1433 ---------------
|
|
|
1434
|
|
|
1435 procedure Set_Color
|
|
|
1436 (Node : Node_Access;
|
|
|
1437 Color : Color_Type)
|
|
|
1438 is
|
|
|
1439 begin
|
|
|
1440 Node.Color := Color;
|
|
|
1441 end Set_Color;
|
|
|
1442
|
|
|
1443 --------------
|
|
|
1444 -- Set_Left --
|
|
|
1445 --------------
|
|
|
1446
|
|
|
1447 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
|
|
|
1448 begin
|
|
|
1449 Node.Left := Left;
|
|
|
1450 end Set_Left;
|
|
|
1451
|
|
|
1452 ----------------
|
|
|
1453 -- Set_Parent --
|
|
|
1454 ----------------
|
|
|
1455
|
|
|
1456 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
|
|
|
1457 begin
|
|
|
1458 Node.Parent := Parent;
|
|
|
1459 end Set_Parent;
|
|
|
1460
|
|
|
1461 ---------------
|
|
|
1462 -- Set_Right --
|
|
|
1463 ---------------
|
|
|
1464
|
|
|
1465 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
|
|
|
1466 begin
|
|
|
1467 Node.Right := Right;
|
|
|
1468 end Set_Right;
|
|
|
1469
|
|
|
1470 --------------------
|
|
|
1471 -- Update_Element --
|
|
|
1472 --------------------
|
|
|
1473
|
|
|
1474 procedure Update_Element
|
|
|
1475 (Container : in out Map;
|
|
|
1476 Position : Cursor;
|
|
|
1477 Process : not null access procedure (Key : Key_Type;
|
|
|
1478 Element : in out Element_Type))
|
|
|
1479 is
|
|
|
1480 begin
|
|
|
1481 if Checks and then Position.Node = null then
|
|
|
1482 raise Constraint_Error with
|
|
|
1483 "Position cursor of Update_Element equals No_Element";
|
|
|
1484 end if;
|
|
|
1485
|
|
|
1486 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1487 then
|
|
|
1488 raise Program_Error with
|
|
|
1489 "Position cursor of Update_Element designates wrong map";
|
|
|
1490 end if;
|
|
|
1491
|
|
|
1492 pragma Assert (Vet (Container.Tree, Position.Node),
|
|
|
1493 "Position cursor of Update_Element is bad");
|
|
|
1494
|
|
|
1495 declare
|
|
|
1496 T : Tree_Type renames Container.Tree;
|
|
|
1497 Lock : With_Lock (T.TC'Unrestricted_Access);
|
|
|
1498 K : Key_Type renames Position.Node.Key;
|
|
|
1499 E : Element_Type renames Position.Node.Element;
|
|
|
1500 begin
|
|
|
1501 Process (K, E);
|
|
|
1502 end;
|
|
|
1503 end Update_Element;
|
|
|
1504
|
|
|
1505 -----------
|
|
|
1506 -- Write --
|
|
|
1507 -----------
|
|
|
1508
|
|
|
1509 procedure Write
|
|
|
1510 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1511 Container : Map)
|
|
|
1512 is
|
|
|
1513 procedure Write_Node
|
|
|
1514 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1515 Node : Node_Access);
|
|
|
1516 pragma Inline (Write_Node);
|
|
|
1517
|
|
|
1518 procedure Write is
|
|
|
1519 new Tree_Operations.Generic_Write (Write_Node);
|
|
|
1520
|
|
|
1521 ----------------
|
|
|
1522 -- Write_Node --
|
|
|
1523 ----------------
|
|
|
1524
|
|
|
1525 procedure Write_Node
|
|
|
1526 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1527 Node : Node_Access)
|
|
|
1528 is
|
|
|
1529 begin
|
|
|
1530 Key_Type'Write (Stream, Node.Key);
|
|
|
1531 Element_Type'Write (Stream, Node.Element);
|
|
|
1532 end Write_Node;
|
|
|
1533
|
|
|
1534 -- Start of processing for Write
|
|
|
1535
|
|
|
1536 begin
|
|
|
1537 Write (Stream, Container.Tree);
|
|
|
1538 end Write;
|
|
|
1539
|
|
|
1540 procedure Write
|
|
|
1541 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1542 Item : Cursor)
|
|
|
1543 is
|
|
|
1544 begin
|
|
|
1545 raise Program_Error with "attempt to stream map cursor";
|
|
|
1546 end Write;
|
|
|
1547
|
|
|
1548 procedure Write
|
|
|
1549 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1550 Item : Reference_Type)
|
|
|
1551 is
|
|
|
1552 begin
|
|
|
1553 raise Program_Error with "attempt to stream reference";
|
|
|
1554 end Write;
|
|
|
1555
|
|
|
1556 procedure Write
|
|
|
1557 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1558 Item : Constant_Reference_Type)
|
|
|
1559 is
|
|
|
1560 begin
|
|
|
1561 raise Program_Error with "attempt to stream reference";
|
|
|
1562 end Write;
|
|
|
1563
|
|
|
1564 end Ada.Containers.Ordered_Maps;
|
