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