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