|
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 -- --
|
|
|
9 -- Copyright (C) 2004-2017, Free Software Foundation, Inc. --
|
|
|
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
|
|
|
484 pragma Assert (Vet (Position.Container.Tree, Position.Node),
|
|
|
485 "Position cursor of function Element is bad");
|
|
|
486
|
|
|
487 return Position.Node.Element;
|
|
|
488 end Element;
|
|
|
489
|
|
|
490 function Element (Container : Map; Key : Key_Type) return Element_Type is
|
|
|
491 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
492
|
|
|
493 begin
|
|
|
494 if Checks and then Node = null then
|
|
|
495 raise Constraint_Error with "key not in map";
|
|
|
496 end if;
|
|
|
497
|
|
|
498 return Node.Element;
|
|
|
499 end Element;
|
|
|
500
|
|
|
501 ---------------------
|
|
|
502 -- Equivalent_Keys --
|
|
|
503 ---------------------
|
|
|
504
|
|
|
505 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
|
|
|
506 begin
|
|
|
507 if Left < Right
|
|
|
508 or else Right < Left
|
|
|
509 then
|
|
|
510 return False;
|
|
|
511 else
|
|
|
512 return True;
|
|
|
513 end if;
|
|
|
514 end Equivalent_Keys;
|
|
|
515
|
|
|
516 -------------
|
|
|
517 -- Exclude --
|
|
|
518 -------------
|
|
|
519
|
|
|
520 procedure Exclude (Container : in out Map; Key : Key_Type) is
|
|
|
521 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
522
|
|
|
523 begin
|
|
|
524 if X /= null then
|
|
|
525 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
|
|
|
526 Free (X);
|
|
|
527 end if;
|
|
|
528 end Exclude;
|
|
|
529
|
|
|
530 --------------
|
|
|
531 -- Finalize --
|
|
|
532 --------------
|
|
|
533
|
|
|
534 procedure Finalize (Object : in out Iterator) is
|
|
|
535 begin
|
|
|
536 if Object.Container /= null then
|
|
|
537 Unbusy (Object.Container.Tree.TC);
|
|
|
538 end if;
|
|
|
539 end Finalize;
|
|
|
540
|
|
|
541 ----------
|
|
|
542 -- Find --
|
|
|
543 ----------
|
|
|
544
|
|
|
545 function Find (Container : Map; Key : Key_Type) return Cursor is
|
|
|
546 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
547 begin
|
|
|
548 return (if Node = null then No_Element
|
|
|
549 else Cursor'(Container'Unrestricted_Access, Node));
|
|
|
550 end Find;
|
|
|
551
|
|
|
552 -----------
|
|
|
553 -- First --
|
|
|
554 -----------
|
|
|
555
|
|
|
556 function First (Container : Map) return Cursor is
|
|
|
557 T : Tree_Type renames Container.Tree;
|
|
|
558 begin
|
|
|
559 if T.First = null then
|
|
|
560 return No_Element;
|
|
|
561 else
|
|
|
562 return Cursor'(Container'Unrestricted_Access, T.First);
|
|
|
563 end if;
|
|
|
564 end First;
|
|
|
565
|
|
|
566 function First (Object : Iterator) return Cursor is
|
|
|
567 begin
|
|
|
568 -- The value of the iterator object's Node component influences the
|
|
|
569 -- behavior of the First (and Last) selector function.
|
|
|
570
|
|
|
571 -- When the Node component is null, this means the iterator object was
|
|
|
572 -- constructed without a start expression, in which case the (forward)
|
|
|
573 -- iteration starts from the (logical) beginning of the entire sequence
|
|
|
574 -- of items (corresponding to Container.First, for a forward iterator).
|
|
|
575
|
|
|
576 -- Otherwise, this is iteration over a partial sequence of items. When
|
|
|
577 -- the Node component is non-null, the iterator object was constructed
|
|
|
578 -- with a start expression, that specifies the position from which the
|
|
|
579 -- (forward) partial iteration begins.
|
|
|
580
|
|
|
581 if Object.Node = null then
|
|
|
582 return Object.Container.First;
|
|
|
583 else
|
|
|
584 return Cursor'(Object.Container, Object.Node);
|
|
|
585 end if;
|
|
|
586 end First;
|
|
|
587
|
|
|
588 -------------------
|
|
|
589 -- First_Element --
|
|
|
590 -------------------
|
|
|
591
|
|
|
592 function First_Element (Container : Map) return Element_Type is
|
|
|
593 T : Tree_Type renames Container.Tree;
|
|
|
594 begin
|
|
|
595 if Checks and then T.First = null then
|
|
|
596 raise Constraint_Error with "map is empty";
|
|
|
597 end if;
|
|
|
598
|
|
|
599 return T.First.Element;
|
|
|
600 end First_Element;
|
|
|
601
|
|
|
602 ---------------
|
|
|
603 -- First_Key --
|
|
|
604 ---------------
|
|
|
605
|
|
|
606 function First_Key (Container : Map) return Key_Type is
|
|
|
607 T : Tree_Type renames Container.Tree;
|
|
|
608 begin
|
|
|
609 if Checks and then T.First = null then
|
|
|
610 raise Constraint_Error with "map is empty";
|
|
|
611 end if;
|
|
|
612
|
|
|
613 return T.First.Key;
|
|
|
614 end First_Key;
|
|
|
615
|
|
|
616 -----------
|
|
|
617 -- Floor --
|
|
|
618 -----------
|
|
|
619
|
|
|
620 function Floor (Container : Map; Key : Key_Type) return Cursor is
|
|
|
621 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
|
|
|
622 begin
|
|
|
623 if Node = null then
|
|
|
624 return No_Element;
|
|
|
625 else
|
|
|
626 return Cursor'(Container'Unrestricted_Access, Node);
|
|
|
627 end if;
|
|
|
628 end Floor;
|
|
|
629
|
|
|
630 ----------
|
|
|
631 -- Free --
|
|
|
632 ----------
|
|
|
633
|
|
|
634 procedure Free (X : in out Node_Access) is
|
|
|
635 procedure Deallocate is
|
|
|
636 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
|
|
|
637
|
|
|
638 begin
|
|
|
639 if X = null then
|
|
|
640 return;
|
|
|
641 end if;
|
|
|
642
|
|
|
643 X.Parent := X;
|
|
|
644 X.Left := X;
|
|
|
645 X.Right := X;
|
|
|
646
|
|
|
647 Deallocate (X);
|
|
|
648 end Free;
|
|
|
649
|
|
|
650 ------------------------
|
|
|
651 -- Get_Element_Access --
|
|
|
652 ------------------------
|
|
|
653
|
|
|
654 function Get_Element_Access
|
|
|
655 (Position : Cursor) return not null Element_Access is
|
|
|
656 begin
|
|
|
657 return Position.Node.Element'Access;
|
|
|
658 end Get_Element_Access;
|
|
|
659
|
|
|
660 -----------------
|
|
|
661 -- Has_Element --
|
|
|
662 -----------------
|
|
|
663
|
|
|
664 function Has_Element (Position : Cursor) return Boolean is
|
|
|
665 begin
|
|
|
666 return Position /= No_Element;
|
|
|
667 end Has_Element;
|
|
|
668
|
|
|
669 -------------
|
|
|
670 -- Include --
|
|
|
671 -------------
|
|
|
672
|
|
|
673 procedure Include
|
|
|
674 (Container : in out Map;
|
|
|
675 Key : Key_Type;
|
|
|
676 New_Item : Element_Type)
|
|
|
677 is
|
|
|
678 Position : Cursor;
|
|
|
679 Inserted : Boolean;
|
|
|
680
|
|
|
681 begin
|
|
|
682 Insert (Container, Key, New_Item, Position, Inserted);
|
|
|
683
|
|
|
684 if not Inserted then
|
|
|
685 TE_Check (Container.Tree.TC);
|
|
|
686
|
|
|
687 Position.Node.Key := Key;
|
|
|
688 Position.Node.Element := New_Item;
|
|
|
689 end if;
|
|
|
690 end Include;
|
|
|
691
|
|
|
692 ------------
|
|
|
693 -- Insert --
|
|
|
694 ------------
|
|
|
695
|
|
|
696 procedure Insert
|
|
|
697 (Container : in out Map;
|
|
|
698 Key : Key_Type;
|
|
|
699 New_Item : Element_Type;
|
|
|
700 Position : out Cursor;
|
|
|
701 Inserted : out Boolean)
|
|
|
702 is
|
|
|
703 function New_Node return Node_Access;
|
|
|
704 pragma Inline (New_Node);
|
|
|
705
|
|
|
706 procedure Insert_Post is
|
|
|
707 new Key_Ops.Generic_Insert_Post (New_Node);
|
|
|
708
|
|
|
709 procedure Insert_Sans_Hint is
|
|
|
710 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
|
|
|
711
|
|
|
712 --------------
|
|
|
713 -- New_Node --
|
|
|
714 --------------
|
|
|
715
|
|
|
716 function New_Node return Node_Access is
|
|
|
717 begin
|
|
|
718 return new Node_Type'(Key => Key,
|
|
|
719 Element => New_Item,
|
|
|
720 Color => Red_Black_Trees.Red,
|
|
|
721 Parent => null,
|
|
|
722 Left => null,
|
|
|
723 Right => null);
|
|
|
724 end New_Node;
|
|
|
725
|
|
|
726 -- Start of processing for Insert
|
|
|
727
|
|
|
728 begin
|
|
|
729 Insert_Sans_Hint
|
|
|
730 (Container.Tree,
|
|
|
731 Key,
|
|
|
732 Position.Node,
|
|
|
733 Inserted);
|
|
|
734
|
|
|
735 Position.Container := Container'Unrestricted_Access;
|
|
|
736 end Insert;
|
|
|
737
|
|
|
738 procedure Insert
|
|
|
739 (Container : in out Map;
|
|
|
740 Key : Key_Type;
|
|
|
741 New_Item : Element_Type)
|
|
|
742 is
|
|
|
743 Position : Cursor;
|
|
|
744 pragma Unreferenced (Position);
|
|
|
745
|
|
|
746 Inserted : Boolean;
|
|
|
747
|
|
|
748 begin
|
|
|
749 Insert (Container, Key, New_Item, Position, Inserted);
|
|
|
750
|
|
|
751 if Checks and then not Inserted then
|
|
|
752 raise Constraint_Error with "key already in map";
|
|
|
753 end if;
|
|
|
754 end Insert;
|
|
|
755
|
|
|
756 procedure Insert
|
|
|
757 (Container : in out Map;
|
|
|
758 Key : Key_Type;
|
|
|
759 Position : out Cursor;
|
|
|
760 Inserted : out Boolean)
|
|
|
761 is
|
|
|
762 function New_Node return Node_Access;
|
|
|
763 pragma Inline (New_Node);
|
|
|
764
|
|
|
765 procedure Insert_Post is
|
|
|
766 new Key_Ops.Generic_Insert_Post (New_Node);
|
|
|
767
|
|
|
768 procedure Insert_Sans_Hint is
|
|
|
769 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
|
|
|
770
|
|
|
771 --------------
|
|
|
772 -- New_Node --
|
|
|
773 --------------
|
|
|
774
|
|
|
775 function New_Node return Node_Access is
|
|
|
776 begin
|
|
|
777 return new Node_Type'(Key => Key,
|
|
|
778 Element => <>,
|
|
|
779 Color => Red_Black_Trees.Red,
|
|
|
780 Parent => null,
|
|
|
781 Left => null,
|
|
|
782 Right => null);
|
|
|
783 end New_Node;
|
|
|
784
|
|
|
785 -- Start of processing for Insert
|
|
|
786
|
|
|
787 begin
|
|
|
788 Insert_Sans_Hint
|
|
|
789 (Container.Tree,
|
|
|
790 Key,
|
|
|
791 Position.Node,
|
|
|
792 Inserted);
|
|
|
793
|
|
|
794 Position.Container := Container'Unrestricted_Access;
|
|
|
795 end Insert;
|
|
|
796
|
|
|
797 --------------
|
|
|
798 -- Is_Empty --
|
|
|
799 --------------
|
|
|
800
|
|
|
801 function Is_Empty (Container : Map) return Boolean is
|
|
|
802 begin
|
|
|
803 return Container.Tree.Length = 0;
|
|
|
804 end Is_Empty;
|
|
|
805
|
|
|
806 ------------------------
|
|
|
807 -- Is_Equal_Node_Node --
|
|
|
808 ------------------------
|
|
|
809
|
|
|
810 function Is_Equal_Node_Node
|
|
|
811 (L, R : Node_Access) return Boolean
|
|
|
812 is
|
|
|
813 begin
|
|
|
814 if L.Key < R.Key then
|
|
|
815 return False;
|
|
|
816 elsif R.Key < L.Key then
|
|
|
817 return False;
|
|
|
818 else
|
|
|
819 return L.Element = R.Element;
|
|
|
820 end if;
|
|
|
821 end Is_Equal_Node_Node;
|
|
|
822
|
|
|
823 -------------------------
|
|
|
824 -- Is_Greater_Key_Node --
|
|
|
825 -------------------------
|
|
|
826
|
|
|
827 function Is_Greater_Key_Node
|
|
|
828 (Left : Key_Type;
|
|
|
829 Right : Node_Access) return Boolean
|
|
|
830 is
|
|
|
831 begin
|
|
|
832 -- Left > Right same as Right < Left
|
|
|
833
|
|
|
834 return Right.Key < Left;
|
|
|
835 end Is_Greater_Key_Node;
|
|
|
836
|
|
|
837 ----------------------
|
|
|
838 -- Is_Less_Key_Node --
|
|
|
839 ----------------------
|
|
|
840
|
|
|
841 function Is_Less_Key_Node
|
|
|
842 (Left : Key_Type;
|
|
|
843 Right : Node_Access) return Boolean
|
|
|
844 is
|
|
|
845 begin
|
|
|
846 return Left < Right.Key;
|
|
|
847 end Is_Less_Key_Node;
|
|
|
848
|
|
|
849 -------------
|
|
|
850 -- Iterate --
|
|
|
851 -------------
|
|
|
852
|
|
|
853 procedure Iterate
|
|
|
854 (Container : Map;
|
|
|
855 Process : not null access procedure (Position : Cursor))
|
|
|
856 is
|
|
|
857 procedure Process_Node (Node : Node_Access);
|
|
|
858 pragma Inline (Process_Node);
|
|
|
859
|
|
|
860 procedure Local_Iterate is
|
|
|
861 new Tree_Operations.Generic_Iteration (Process_Node);
|
|
|
862
|
|
|
863 ------------------
|
|
|
864 -- Process_Node --
|
|
|
865 ------------------
|
|
|
866
|
|
|
867 procedure Process_Node (Node : Node_Access) is
|
|
|
868 begin
|
|
|
869 Process (Cursor'(Container'Unrestricted_Access, Node));
|
|
|
870 end Process_Node;
|
|
|
871
|
|
|
872 Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
|
|
|
873
|
|
|
874 -- Start of processing for Iterate
|
|
|
875
|
|
|
876 begin
|
|
|
877 Local_Iterate (Container.Tree);
|
|
|
878 end Iterate;
|
|
|
879
|
|
|
880 function Iterate
|
|
|
881 (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
|
|
|
882 is
|
|
|
883 begin
|
|
|
884 -- The value of the Node component influences the behavior of the First
|
|
|
885 -- and Last selector functions of the iterator object. When the Node
|
|
|
886 -- component is null (as is the case here), this means the iterator
|
|
|
887 -- object was constructed without a start expression. This is a
|
|
|
888 -- complete iterator, meaning that the iteration starts from the
|
|
|
889 -- (logical) beginning of the sequence of items.
|
|
|
890
|
|
|
891 -- Note: For a forward iterator, Container.First is the beginning, and
|
|
|
892 -- for a reverse iterator, Container.Last is the beginning.
|
|
|
893
|
|
|
894 return It : constant Iterator :=
|
|
|
895 (Limited_Controlled with
|
|
|
896 Container => Container'Unrestricted_Access,
|
|
|
897 Node => null)
|
|
|
898 do
|
|
|
899 Busy (Container.Tree.TC'Unrestricted_Access.all);
|
|
|
900 end return;
|
|
|
901 end Iterate;
|
|
|
902
|
|
|
903 function Iterate (Container : Map; Start : Cursor)
|
|
|
904 return Map_Iterator_Interfaces.Reversible_Iterator'Class
|
|
|
905 is
|
|
|
906 begin
|
|
|
907 -- It was formerly the case that when Start = No_Element, the partial
|
|
|
908 -- iterator was defined to behave the same as for a complete iterator,
|
|
|
909 -- and iterate over the entire sequence of items. However, those
|
|
|
910 -- semantics were unintuitive and arguably error-prone (it is too easy
|
|
|
911 -- to accidentally create an endless loop), and so they were changed,
|
|
|
912 -- per the ARG meeting in Denver on 2011/11. However, there was no
|
|
|
913 -- consensus about what positive meaning this corner case should have,
|
|
|
914 -- and so it was decided to simply raise an exception. This does imply,
|
|
|
915 -- however, that it is not possible to use a partial iterator to specify
|
|
|
916 -- an empty sequence of items.
|
|
|
917
|
|
|
918 if Checks and then Start = No_Element then
|
|
|
919 raise Constraint_Error with
|
|
|
920 "Start position for iterator equals No_Element";
|
|
|
921 end if;
|
|
|
922
|
|
|
923 if Checks and then Start.Container /= Container'Unrestricted_Access then
|
|
|
924 raise Program_Error with
|
|
|
925 "Start cursor of Iterate designates wrong map";
|
|
|
926 end if;
|
|
|
927
|
|
|
928 pragma Assert (Vet (Container.Tree, Start.Node),
|
|
|
929 "Start cursor of Iterate is bad");
|
|
|
930
|
|
|
931 -- The value of the Node component influences the behavior of the First
|
|
|
932 -- and Last selector functions of the iterator object. When the Node
|
|
|
933 -- component is non-null (as is the case here), it means that this
|
|
|
934 -- is a partial iteration, over a subset of the complete sequence of
|
|
|
935 -- items. The iterator object was constructed with a start expression,
|
|
|
936 -- indicating the position from which the iteration begins. Note that
|
|
|
937 -- the start position has the same value irrespective of whether this
|
|
|
938 -- is a forward or reverse iteration.
|
|
|
939
|
|
|
940 return It : constant Iterator :=
|
|
|
941 (Limited_Controlled with
|
|
|
942 Container => Container'Unrestricted_Access,
|
|
|
943 Node => Start.Node)
|
|
|
944 do
|
|
|
945 Busy (Container.Tree.TC'Unrestricted_Access.all);
|
|
|
946 end return;
|
|
|
947 end Iterate;
|
|
|
948
|
|
|
949 ---------
|
|
|
950 -- Key --
|
|
|
951 ---------
|
|
|
952
|
|
|
953 function Key (Position : Cursor) return Key_Type is
|
|
|
954 begin
|
|
|
955 if Checks and then Position.Node = null then
|
|
|
956 raise Constraint_Error with
|
|
|
957 "Position cursor of function Key equals No_Element";
|
|
|
958 end if;
|
|
|
959
|
|
|
960 pragma Assert (Vet (Position.Container.Tree, Position.Node),
|
|
|
961 "Position cursor of function Key is bad");
|
|
|
962
|
|
|
963 return Position.Node.Key;
|
|
|
964 end Key;
|
|
|
965
|
|
|
966 ----------
|
|
|
967 -- Last --
|
|
|
968 ----------
|
|
|
969
|
|
|
970 function Last (Container : Map) return Cursor is
|
|
|
971 T : Tree_Type renames Container.Tree;
|
|
|
972 begin
|
|
|
973 if T.Last = null then
|
|
|
974 return No_Element;
|
|
|
975 else
|
|
|
976 return Cursor'(Container'Unrestricted_Access, T.Last);
|
|
|
977 end if;
|
|
|
978 end Last;
|
|
|
979
|
|
|
980 function Last (Object : Iterator) return Cursor is
|
|
|
981 begin
|
|
|
982 -- The value of the iterator object's Node component influences the
|
|
|
983 -- behavior of the Last (and First) selector function.
|
|
|
984
|
|
|
985 -- When the Node component is null, this means the iterator object was
|
|
|
986 -- constructed without a start expression, in which case the (reverse)
|
|
|
987 -- iteration starts from the (logical) beginning of the entire sequence
|
|
|
988 -- (corresponding to Container.Last, for a reverse iterator).
|
|
|
989
|
|
|
990 -- Otherwise, this is iteration over a partial sequence of items. When
|
|
|
991 -- the Node component is non-null, the iterator object was constructed
|
|
|
992 -- with a start expression, that specifies the position from which the
|
|
|
993 -- (reverse) partial iteration begins.
|
|
|
994
|
|
|
995 if Object.Node = null then
|
|
|
996 return Object.Container.Last;
|
|
|
997 else
|
|
|
998 return Cursor'(Object.Container, Object.Node);
|
|
|
999 end if;
|
|
|
1000 end Last;
|
|
|
1001
|
|
|
1002 ------------------
|
|
|
1003 -- Last_Element --
|
|
|
1004 ------------------
|
|
|
1005
|
|
|
1006 function Last_Element (Container : Map) return Element_Type is
|
|
|
1007 T : Tree_Type renames Container.Tree;
|
|
|
1008 begin
|
|
|
1009 if Checks and then T.Last = null then
|
|
|
1010 raise Constraint_Error with "map is empty";
|
|
|
1011 end if;
|
|
|
1012
|
|
|
1013 return T.Last.Element;
|
|
|
1014 end Last_Element;
|
|
|
1015
|
|
|
1016 --------------
|
|
|
1017 -- Last_Key --
|
|
|
1018 --------------
|
|
|
1019
|
|
|
1020 function Last_Key (Container : Map) return Key_Type is
|
|
|
1021 T : Tree_Type renames Container.Tree;
|
|
|
1022 begin
|
|
|
1023 if Checks and then T.Last = null then
|
|
|
1024 raise Constraint_Error with "map is empty";
|
|
|
1025 end if;
|
|
|
1026
|
|
|
1027 return T.Last.Key;
|
|
|
1028 end Last_Key;
|
|
|
1029
|
|
|
1030 ----------
|
|
|
1031 -- Left --
|
|
|
1032 ----------
|
|
|
1033
|
|
|
1034 function Left (Node : Node_Access) return Node_Access is
|
|
|
1035 begin
|
|
|
1036 return Node.Left;
|
|
|
1037 end Left;
|
|
|
1038
|
|
|
1039 ------------
|
|
|
1040 -- Length --
|
|
|
1041 ------------
|
|
|
1042
|
|
|
1043 function Length (Container : Map) return Count_Type is
|
|
|
1044 begin
|
|
|
1045 return Container.Tree.Length;
|
|
|
1046 end Length;
|
|
|
1047
|
|
|
1048 ----------
|
|
|
1049 -- Move --
|
|
|
1050 ----------
|
|
|
1051
|
|
|
1052 procedure Move is
|
|
|
1053 new Tree_Operations.Generic_Move (Clear);
|
|
|
1054
|
|
|
1055 procedure Move (Target : in out Map; Source : in out Map) is
|
|
|
1056 begin
|
|
|
1057 Move (Target => Target.Tree, Source => Source.Tree);
|
|
|
1058 end Move;
|
|
|
1059
|
|
|
1060 ----------
|
|
|
1061 -- Next --
|
|
|
1062 ----------
|
|
|
1063
|
|
|
1064 procedure Next (Position : in out Cursor) is
|
|
|
1065 begin
|
|
|
1066 Position := Next (Position);
|
|
|
1067 end Next;
|
|
|
1068
|
|
|
1069 function Next (Position : Cursor) return Cursor is
|
|
|
1070 begin
|
|
|
1071 if Position = No_Element then
|
|
|
1072 return No_Element;
|
|
|
1073 end if;
|
|
|
1074
|
|
|
1075 pragma Assert (Vet (Position.Container.Tree, Position.Node),
|
|
|
1076 "Position cursor of Next is bad");
|
|
|
1077
|
|
|
1078 declare
|
|
|
1079 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
|
|
|
1080
|
|
|
1081 begin
|
|
|
1082 if Node = null then
|
|
|
1083 return No_Element;
|
|
|
1084 end if;
|
|
|
1085
|
|
|
1086 return Cursor'(Position.Container, Node);
|
|
|
1087 end;
|
|
|
1088 end Next;
|
|
|
1089
|
|
|
1090 function Next
|
|
|
1091 (Object : Iterator;
|
|
|
1092 Position : Cursor) return Cursor
|
|
|
1093 is
|
|
|
1094 begin
|
|
|
1095 if Position.Container = null then
|
|
|
1096 return No_Element;
|
|
|
1097 end if;
|
|
|
1098
|
|
|
1099 if Checks and then Position.Container /= Object.Container then
|
|
|
1100 raise Program_Error with
|
|
|
1101 "Position cursor of Next designates wrong map";
|
|
|
1102 end if;
|
|
|
1103
|
|
|
1104 return Next (Position);
|
|
|
1105 end Next;
|
|
|
1106
|
|
|
1107 ------------
|
|
|
1108 -- Parent --
|
|
|
1109 ------------
|
|
|
1110
|
|
|
1111 function Parent (Node : Node_Access) return Node_Access is
|
|
|
1112 begin
|
|
|
1113 return Node.Parent;
|
|
|
1114 end Parent;
|
|
|
1115
|
|
|
1116 --------------
|
|
|
1117 -- Previous --
|
|
|
1118 --------------
|
|
|
1119
|
|
|
1120 procedure Previous (Position : in out Cursor) is
|
|
|
1121 begin
|
|
|
1122 Position := Previous (Position);
|
|
|
1123 end Previous;
|
|
|
1124
|
|
|
1125 function Previous (Position : Cursor) return Cursor is
|
|
|
1126 begin
|
|
|
1127 if Position = No_Element then
|
|
|
1128 return No_Element;
|
|
|
1129 end if;
|
|
|
1130
|
|
|
1131 pragma Assert (Vet (Position.Container.Tree, Position.Node),
|
|
|
1132 "Position cursor of Previous is bad");
|
|
|
1133
|
|
|
1134 declare
|
|
|
1135 Node : constant Node_Access :=
|
|
|
1136 Tree_Operations.Previous (Position.Node);
|
|
|
1137
|
|
|
1138 begin
|
|
|
1139 if Node = null then
|
|
|
1140 return No_Element;
|
|
|
1141 end if;
|
|
|
1142
|
|
|
1143 return Cursor'(Position.Container, Node);
|
|
|
1144 end;
|
|
|
1145 end Previous;
|
|
|
1146
|
|
|
1147 function Previous
|
|
|
1148 (Object : Iterator;
|
|
|
1149 Position : Cursor) return Cursor
|
|
|
1150 is
|
|
|
1151 begin
|
|
|
1152 if Position.Container = null then
|
|
|
1153 return No_Element;
|
|
|
1154 end if;
|
|
|
1155
|
|
|
1156 if Checks and then Position.Container /= Object.Container then
|
|
|
1157 raise Program_Error with
|
|
|
1158 "Position cursor of Previous designates wrong map";
|
|
|
1159 end if;
|
|
|
1160
|
|
|
1161 return Previous (Position);
|
|
|
1162 end Previous;
|
|
|
1163
|
|
|
1164 ----------------------
|
|
|
1165 -- Pseudo_Reference --
|
|
|
1166 ----------------------
|
|
|
1167
|
|
|
1168 function Pseudo_Reference
|
|
|
1169 (Container : aliased Map'Class) return Reference_Control_Type
|
|
|
1170 is
|
|
|
1171 TC : constant Tamper_Counts_Access :=
|
|
|
1172 Container.Tree.TC'Unrestricted_Access;
|
|
|
1173 begin
|
|
|
1174 return R : constant Reference_Control_Type := (Controlled with TC) do
|
|
|
1175 Lock (TC.all);
|
|
|
1176 end return;
|
|
|
1177 end Pseudo_Reference;
|
|
|
1178
|
|
|
1179 -------------------
|
|
|
1180 -- Query_Element --
|
|
|
1181 -------------------
|
|
|
1182
|
|
|
1183 procedure Query_Element
|
|
|
1184 (Position : Cursor;
|
|
|
1185 Process : not null access procedure (Key : Key_Type;
|
|
|
1186 Element : Element_Type))
|
|
|
1187 is
|
|
|
1188 begin
|
|
|
1189 if Checks and then Position.Node = null then
|
|
|
1190 raise Constraint_Error with
|
|
|
1191 "Position cursor of Query_Element equals No_Element";
|
|
|
1192 end if;
|
|
|
1193
|
|
|
1194 pragma Assert (Vet (Position.Container.Tree, Position.Node),
|
|
|
1195 "Position cursor of Query_Element is bad");
|
|
|
1196
|
|
|
1197 declare
|
|
|
1198 T : Tree_Type renames Position.Container.Tree;
|
|
|
1199 Lock : With_Lock (T.TC'Unrestricted_Access);
|
|
|
1200 K : Key_Type renames Position.Node.Key;
|
|
|
1201 E : Element_Type renames Position.Node.Element;
|
|
|
1202 begin
|
|
|
1203 Process (K, E);
|
|
|
1204 end;
|
|
|
1205 end Query_Element;
|
|
|
1206
|
|
|
1207 ----------
|
|
|
1208 -- Read --
|
|
|
1209 ----------
|
|
|
1210
|
|
|
1211 procedure Read
|
|
|
1212 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1213 Container : out Map)
|
|
|
1214 is
|
|
|
1215 function Read_Node
|
|
|
1216 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
|
|
|
1217 pragma Inline (Read_Node);
|
|
|
1218
|
|
|
1219 procedure Read is
|
|
|
1220 new Tree_Operations.Generic_Read (Clear, Read_Node);
|
|
|
1221
|
|
|
1222 ---------------
|
|
|
1223 -- Read_Node --
|
|
|
1224 ---------------
|
|
|
1225
|
|
|
1226 function Read_Node
|
|
|
1227 (Stream : not null access Root_Stream_Type'Class) return Node_Access
|
|
|
1228 is
|
|
|
1229 Node : Node_Access := new Node_Type;
|
|
|
1230 begin
|
|
|
1231 Key_Type'Read (Stream, Node.Key);
|
|
|
1232 Element_Type'Read (Stream, Node.Element);
|
|
|
1233 return Node;
|
|
|
1234 exception
|
|
|
1235 when others =>
|
|
|
1236 Free (Node);
|
|
|
1237 raise;
|
|
|
1238 end Read_Node;
|
|
|
1239
|
|
|
1240 -- Start of processing for Read
|
|
|
1241
|
|
|
1242 begin
|
|
|
1243 Read (Stream, Container.Tree);
|
|
|
1244 end Read;
|
|
|
1245
|
|
|
1246 procedure Read
|
|
|
1247 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1248 Item : out Cursor)
|
|
|
1249 is
|
|
|
1250 begin
|
|
|
1251 raise Program_Error with "attempt to stream map cursor";
|
|
|
1252 end Read;
|
|
|
1253
|
|
|
1254 procedure Read
|
|
|
1255 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1256 Item : out Reference_Type)
|
|
|
1257 is
|
|
|
1258 begin
|
|
|
1259 raise Program_Error with "attempt to stream reference";
|
|
|
1260 end Read;
|
|
|
1261
|
|
|
1262 procedure Read
|
|
|
1263 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1264 Item : out Constant_Reference_Type)
|
|
|
1265 is
|
|
|
1266 begin
|
|
|
1267 raise Program_Error with "attempt to stream reference";
|
|
|
1268 end Read;
|
|
|
1269
|
|
|
1270 ---------------
|
|
|
1271 -- Reference --
|
|
|
1272 ---------------
|
|
|
1273
|
|
|
1274 function Reference
|
|
|
1275 (Container : aliased in out Map;
|
|
|
1276 Position : Cursor) return Reference_Type
|
|
|
1277 is
|
|
|
1278 begin
|
|
|
1279 if Checks and then Position.Container = null then
|
|
|
1280 raise Constraint_Error with
|
|
|
1281 "Position cursor has no element";
|
|
|
1282 end if;
|
|
|
1283
|
|
|
1284 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1285 then
|
|
|
1286 raise Program_Error with
|
|
|
1287 "Position cursor designates wrong map";
|
|
|
1288 end if;
|
|
|
1289
|
|
|
1290 pragma Assert (Vet (Container.Tree, Position.Node),
|
|
|
1291 "Position cursor in function Reference is bad");
|
|
|
1292
|
|
|
1293 declare
|
|
|
1294 T : Tree_Type renames Position.Container.all.Tree;
|
|
|
1295 TC : constant Tamper_Counts_Access :=
|
|
|
1296 T.TC'Unrestricted_Access;
|
|
|
1297 begin
|
|
|
1298 return R : constant Reference_Type :=
|
|
|
1299 (Element => Position.Node.Element'Access,
|
|
|
1300 Control => (Controlled with TC))
|
|
|
1301 do
|
|
|
1302 Lock (TC.all);
|
|
|
1303 end return;
|
|
|
1304 end;
|
|
|
1305 end Reference;
|
|
|
1306
|
|
|
1307 function Reference
|
|
|
1308 (Container : aliased in out Map;
|
|
|
1309 Key : Key_Type) return Reference_Type
|
|
|
1310 is
|
|
|
1311 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
1312
|
|
|
1313 begin
|
|
|
1314 if Checks and then Node = null then
|
|
|
1315 raise Constraint_Error with "key not in map";
|
|
|
1316 end if;
|
|
|
1317
|
|
|
1318 declare
|
|
|
1319 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
|
|
|
1320 TC : constant Tamper_Counts_Access :=
|
|
|
1321 T.TC'Unrestricted_Access;
|
|
|
1322 begin
|
|
|
1323 return R : constant Reference_Type :=
|
|
|
1324 (Element => Node.Element'Access,
|
|
|
1325 Control => (Controlled with TC))
|
|
|
1326 do
|
|
|
1327 Lock (TC.all);
|
|
|
1328 end return;
|
|
|
1329 end;
|
|
|
1330 end Reference;
|
|
|
1331
|
|
|
1332 -------------
|
|
|
1333 -- Replace --
|
|
|
1334 -------------
|
|
|
1335
|
|
|
1336 procedure Replace
|
|
|
1337 (Container : in out Map;
|
|
|
1338 Key : Key_Type;
|
|
|
1339 New_Item : Element_Type)
|
|
|
1340 is
|
|
|
1341 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
|
|
|
1342
|
|
|
1343 begin
|
|
|
1344 if Checks and then Node = null then
|
|
|
1345 raise Constraint_Error with "key not in map";
|
|
|
1346 end if;
|
|
|
1347
|
|
|
1348 TE_Check (Container.Tree.TC);
|
|
|
1349
|
|
|
1350 Node.Key := Key;
|
|
|
1351 Node.Element := New_Item;
|
|
|
1352 end Replace;
|
|
|
1353
|
|
|
1354 ---------------------
|
|
|
1355 -- Replace_Element --
|
|
|
1356 ---------------------
|
|
|
1357
|
|
|
1358 procedure Replace_Element
|
|
|
1359 (Container : in out Map;
|
|
|
1360 Position : Cursor;
|
|
|
1361 New_Item : Element_Type)
|
|
|
1362 is
|
|
|
1363 begin
|
|
|
1364 if Checks and then Position.Node = null then
|
|
|
1365 raise Constraint_Error with
|
|
|
1366 "Position cursor of Replace_Element equals No_Element";
|
|
|
1367 end if;
|
|
|
1368
|
|
|
1369 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1370 then
|
|
|
1371 raise Program_Error with
|
|
|
1372 "Position cursor of Replace_Element designates wrong map";
|
|
|
1373 end if;
|
|
|
1374
|
|
|
1375 TE_Check (Container.Tree.TC);
|
|
|
1376
|
|
|
1377 pragma Assert (Vet (Container.Tree, Position.Node),
|
|
|
1378 "Position cursor of Replace_Element is bad");
|
|
|
1379
|
|
|
1380 Position.Node.Element := New_Item;
|
|
|
1381 end Replace_Element;
|
|
|
1382
|
|
|
1383 ---------------------
|
|
|
1384 -- Reverse_Iterate --
|
|
|
1385 ---------------------
|
|
|
1386
|
|
|
1387 procedure Reverse_Iterate
|
|
|
1388 (Container : Map;
|
|
|
1389 Process : not null access procedure (Position : Cursor))
|
|
|
1390 is
|
|
|
1391 procedure Process_Node (Node : Node_Access);
|
|
|
1392 pragma Inline (Process_Node);
|
|
|
1393
|
|
|
1394 procedure Local_Reverse_Iterate is
|
|
|
1395 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
|
|
|
1396
|
|
|
1397 ------------------
|
|
|
1398 -- Process_Node --
|
|
|
1399 ------------------
|
|
|
1400
|
|
|
1401 procedure Process_Node (Node : Node_Access) is
|
|
|
1402 begin
|
|
|
1403 Process (Cursor'(Container'Unrestricted_Access, Node));
|
|
|
1404 end Process_Node;
|
|
|
1405
|
|
|
1406 Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
|
|
|
1407
|
|
|
1408 -- Start of processing for Reverse_Iterate
|
|
|
1409
|
|
|
1410 begin
|
|
|
1411 Local_Reverse_Iterate (Container.Tree);
|
|
|
1412 end Reverse_Iterate;
|
|
|
1413
|
|
|
1414 -----------
|
|
|
1415 -- Right --
|
|
|
1416 -----------
|
|
|
1417
|
|
|
1418 function Right (Node : Node_Access) return Node_Access is
|
|
|
1419 begin
|
|
|
1420 return Node.Right;
|
|
|
1421 end Right;
|
|
|
1422
|
|
|
1423 ---------------
|
|
|
1424 -- Set_Color --
|
|
|
1425 ---------------
|
|
|
1426
|
|
|
1427 procedure Set_Color
|
|
|
1428 (Node : Node_Access;
|
|
|
1429 Color : Color_Type)
|
|
|
1430 is
|
|
|
1431 begin
|
|
|
1432 Node.Color := Color;
|
|
|
1433 end Set_Color;
|
|
|
1434
|
|
|
1435 --------------
|
|
|
1436 -- Set_Left --
|
|
|
1437 --------------
|
|
|
1438
|
|
|
1439 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
|
|
|
1440 begin
|
|
|
1441 Node.Left := Left;
|
|
|
1442 end Set_Left;
|
|
|
1443
|
|
|
1444 ----------------
|
|
|
1445 -- Set_Parent --
|
|
|
1446 ----------------
|
|
|
1447
|
|
|
1448 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
|
|
|
1449 begin
|
|
|
1450 Node.Parent := Parent;
|
|
|
1451 end Set_Parent;
|
|
|
1452
|
|
|
1453 ---------------
|
|
|
1454 -- Set_Right --
|
|
|
1455 ---------------
|
|
|
1456
|
|
|
1457 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
|
|
|
1458 begin
|
|
|
1459 Node.Right := Right;
|
|
|
1460 end Set_Right;
|
|
|
1461
|
|
|
1462 --------------------
|
|
|
1463 -- Update_Element --
|
|
|
1464 --------------------
|
|
|
1465
|
|
|
1466 procedure Update_Element
|
|
|
1467 (Container : in out Map;
|
|
|
1468 Position : Cursor;
|
|
|
1469 Process : not null access procedure (Key : Key_Type;
|
|
|
1470 Element : in out Element_Type))
|
|
|
1471 is
|
|
|
1472 begin
|
|
|
1473 if Checks and then Position.Node = null then
|
|
|
1474 raise Constraint_Error with
|
|
|
1475 "Position cursor of Update_Element equals No_Element";
|
|
|
1476 end if;
|
|
|
1477
|
|
|
1478 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1479 then
|
|
|
1480 raise Program_Error with
|
|
|
1481 "Position cursor of Update_Element designates wrong map";
|
|
|
1482 end if;
|
|
|
1483
|
|
|
1484 pragma Assert (Vet (Container.Tree, Position.Node),
|
|
|
1485 "Position cursor of Update_Element is bad");
|
|
|
1486
|
|
|
1487 declare
|
|
|
1488 T : Tree_Type renames Container.Tree;
|
|
|
1489 Lock : With_Lock (T.TC'Unrestricted_Access);
|
|
|
1490 K : Key_Type renames Position.Node.Key;
|
|
|
1491 E : Element_Type renames Position.Node.Element;
|
|
|
1492 begin
|
|
|
1493 Process (K, E);
|
|
|
1494 end;
|
|
|
1495 end Update_Element;
|
|
|
1496
|
|
|
1497 -----------
|
|
|
1498 -- Write --
|
|
|
1499 -----------
|
|
|
1500
|
|
|
1501 procedure Write
|
|
|
1502 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1503 Container : Map)
|
|
|
1504 is
|
|
|
1505 procedure Write_Node
|
|
|
1506 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1507 Node : Node_Access);
|
|
|
1508 pragma Inline (Write_Node);
|
|
|
1509
|
|
|
1510 procedure Write is
|
|
|
1511 new Tree_Operations.Generic_Write (Write_Node);
|
|
|
1512
|
|
|
1513 ----------------
|
|
|
1514 -- Write_Node --
|
|
|
1515 ----------------
|
|
|
1516
|
|
|
1517 procedure Write_Node
|
|
|
1518 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1519 Node : Node_Access)
|
|
|
1520 is
|
|
|
1521 begin
|
|
|
1522 Key_Type'Write (Stream, Node.Key);
|
|
|
1523 Element_Type'Write (Stream, Node.Element);
|
|
|
1524 end Write_Node;
|
|
|
1525
|
|
|
1526 -- Start of processing for Write
|
|
|
1527
|
|
|
1528 begin
|
|
|
1529 Write (Stream, Container.Tree);
|
|
|
1530 end Write;
|
|
|
1531
|
|
|
1532 procedure Write
|
|
|
1533 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1534 Item : Cursor)
|
|
|
1535 is
|
|
|
1536 begin
|
|
|
1537 raise Program_Error with "attempt to stream map cursor";
|
|
|
1538 end Write;
|
|
|
1539
|
|
|
1540 procedure Write
|
|
|
1541 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1542 Item : Reference_Type)
|
|
|
1543 is
|
|
|
1544 begin
|
|
|
1545 raise Program_Error with "attempt to stream reference";
|
|
|
1546 end Write;
|
|
|
1547
|
|
|
1548 procedure Write
|
|
|
1549 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1550 Item : Constant_Reference_Type)
|
|
|
1551 is
|
|
|
1552 begin
|
|
|
1553 raise Program_Error with "attempt to stream reference";
|
|
|
1554 end Write;
|
|
|
1555
|
|
|
1556 end Ada.Containers.Ordered_Maps;
|
